gcc/testsuite/ada/acats/tests/c3/c392010.a

   1 -- C392010.A
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     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 WHATSOEVER, 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 that a subprogram dispatches correctly with a controlling
  28 --     access parameter. Check that a subprogram dispatches correctly
  29 --     when it has access parameters that are not controlling.
  30 --     Check with and without default expressions.
  31 --
  32 -- TEST DESCRIPTION:
  33 --      The three packages define layers of tagged types.  The root tagged
  34 --      type contains a character value used to check that the right object
  35 --      got passed to the right routine.  Each subprogram has a unique
  36 --      TCTouch tag, upper case values are used for subprograms, lower case
  37 --      values are used for object values.
  38 --
  39 --      Notes on style: the "tagged" comment lines --I and --A represent
  40 --      commentary about what gets inherited and what becomes abstract,
  41 --      respectively.  The author felt these to be necessary with this test
  42 --      to reduce some of the additional complexities.
  43 --
  44 --3.9.2(16,17,18,20);6.0
  45 --
  46 -- CHANGE HISTORY:
  47 --      22 SEP 95   SAIC   Initial version
  48 --      22 APR 96   SAIC   Revised for 2.1
  49 --      05 JAN 98   EDS    Change return type of C392010_2.Func_W_Non to make
  50 --                         it override.
  51 --      21 JUN 00   RLB    Changed expected result to reflect the appropriate
  52 --                         value of the default expression.
  53 --      20 JUL 00   RLB    Removed entire call pending resolution by the ARG.
  54
  55 --!
  56
  57 ----------------------------------------------------------------- C392010_0
  58
  59 package C392010_0 is
  60
  61   -- define a root tagged type
  62   type Tagtype_Level_0 is tagged record
  63     Ch_Item : Character;
  64   end record;
  65
  66   type Access_Procedure is access procedure( P: Tagtype_Level_0 );
  67
  68   procedure Proc_1( P: Tagtype_Level_0 );
  69
  70   procedure Proc_2( P: Tagtype_Level_0 );
  71
  72   function A_Default_Value return Tagtype_Level_0;
  73
  74   procedure Proc_w_Ap_and_Cp( AP : Access_Procedure;
  75                               Cp : Tagtype_Level_0 );
  76     -- has both access procedure and controlling parameter
  77
  78   procedure Proc_w_Ap_and_Cp_w_Def( AP : Access_Procedure := Proc_2'Access;
  79                                     Cp : Tagtype_Level_0
  80                                        := A_Default_Value );   ------------ z
  81     -- has both access procedure and controlling parameter with defaults
  82
  83   -- for the objective:
  84 --     Check that access parameters may be controlling.
  85
  86   procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_0 );
  87     -- has access parameter that is controlling
  88
  89   function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_0 )
  90            return Tagtype_Level_0;
  91     -- has access parameter that is controlling, and controlling result
  92
  93   Level_0_Global_Object : aliased Tagtype_Level_0
  94                         := ( Ch_Item => 'a' );  ---------------------------- a
  95
  96 end C392010_0;
  97
  98 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
  99
 100 with TCTouch;
 101 package body C392010_0 is
 102
 103   procedure Proc_1( P: Tagtype_Level_0 ) is
 104   begin
 105     TCTouch.Touch('A');  --------------------------------------------------- A
 106     TCTouch.Touch(P.Ch_Item);  -- depends on the value passed -------------- ?
 107   end Proc_1;
 108
 109   procedure Proc_2( P: Tagtype_Level_0 ) is
 110   begin
 111     TCTouch.Touch('B');  --------------------------------------------------- B
 112     TCTouch.Touch(P.Ch_Item);  -- depends on the value passed -------------- ?
 113   end Proc_2;
 114
 115   function A_Default_Value return Tagtype_Level_0 is
 116   begin
 117     return (Ch_Item => 'z');  ---------------------------------------------- z
 118   end A_Default_Value;
 119
 120   procedure Proc_w_Ap_and_Cp( Ap : Access_Procedure;
 121                               Cp : Tagtype_Level_0 ) is
 122   begin
 123     TCTouch.Touch('C');  --------------------------------------------------- C
 124     Ap.all( Cp );
 125   end Proc_w_Ap_and_Cp;
 126
 127   procedure Proc_w_Ap_and_Cp_w_Def( AP : Access_Procedure := Proc_2'Access;
 128                                     Cp : Tagtype_Level_0
 129                                        := A_Default_Value ) is
 130   begin
 131     TCTouch.Touch('D');  --------------------------------------------------- D
 132     Ap.all( Cp );
 133   end Proc_w_Ap_and_Cp_w_Def;
 134
 135   procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_0 ) is
 136   begin
 137     TCTouch.Touch('E');  --------------------------------------------------- E
 138     TCTouch.Touch(Cp_Ap.Ch_Item);  -- depends on the value passed ---------- ?
 139   end Proc_w_Cp_Ap;
 140
 141   function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_0 )
 142            return Tagtype_Level_0 is
 143   begin
 144     TCTouch.Touch('F');  --------------------------------------------------- F
 145     TCTouch.Touch(Cp_Ap.Ch_Item);  -- depends on the value passed ---------- ?
 146     return ( Ch_Item => 'b' );  -------------------------------------------- b
 147   end Func_w_Cp_Ap_and_Cr;
 148
 149 end C392010_0;
 150
 151 ----------------------------------------------------------------- C392010_1
 152
 153 with C392010_0;
 154 package C392010_1 is
 155
 156   type Tagtype_Level_1 is new C392010_0.Tagtype_Level_0 with record
 157     Int_Item : Integer;
 158   end record;
 159
 160   type Access_Tagtype_Level_1 is access all Tagtype_Level_1'Class;
 161
 162   -- the following procedures are inherited by the above declaration:
 163   --I   procedure Proc_1( P: Tagtype_Level_1 );
 164   --I
 165   --I   procedure Proc_2( P: Tagtype_Level_1 );
 166   --I
 167   --I   procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure;
 168   --I                               Cp : Tagtype_Level_1 );
 169   --I
 170   --I   procedure Proc_w_Ap_and_Cp_w_Def
 171   --I             ( AP : C392010_0.Access_Procedure := Proc_2'Access;
 172   --I               Cp : Tagtype_Level_1 := A_Default_Value );
 173   --I
 174   --I   procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 );
 175   --I
 176
 177   -- the following functions become abstract due to the above declaration:
 178   --A   function A_Default_Value return Tagtype_Level_1;
 179   --A
 180   --A   function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 )
 181   --A            return Tagtype_Level_1;
 182
 183   -- so, in the interest of testing dispatching, we override them all:
 184      -- except Proc_1 and Proc_2
 185
 186   procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure;
 187                               Cp : Tagtype_Level_1 );
 188
 189   function A_Default_Value return Tagtype_Level_1;
 190
 191   procedure Proc_w_Ap_and_Cp_w_Def(
 192               AP : C392010_0.Access_Procedure := C392010_0.Proc_2'Access;
 193               Cp : Tagtype_Level_1 := A_Default_Value );
 194
 195  procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 );
 196
 197   function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 )
 198            return Tagtype_Level_1;
 199
 200   -- to test the objective:
 201 --     Check that a subprogram dispatches correctly when it has
 202 --     access parameters that are not controlling.
 203
 204   procedure Proc_w_Non( Cp_Ap    : access Tagtype_Level_1;
 205                         NonCp_Ap : access C392010_0.Tagtype_Level_0
 206                              := C392010_0.Level_0_Global_Object'Access );
 207
 208   function Func_w_Non( Cp_Ap : access Tagtype_Level_1;
 209                     NonCp_Ap : access C392010_0.Tagtype_Level_0
 210                              := C392010_0.Level_0_Global_Object'Access )
 211            return Access_Tagtype_Level_1;
 212
 213   Level_1_Global_Object : aliased Tagtype_Level_1
 214                         := ( Int_Item => 0,
 215                              Ch_Item  => 'c' );  --------------------------- c
 216
 217 end C392010_1;
 218
 219 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 220
 221 with TCTouch;
 222 package body C392010_1 is
 223
 224   procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure;
 225                               Cp : Tagtype_Level_1 ) is
 226   begin
 227     TCTouch.Touch('G');  --------------------------------------------------- G
 228     Ap.All( C392010_0.Tagtype_Level_0( Cp ) );
 229   end Proc_w_Ap_and_Cp;
 230
 231   procedure Proc_w_Ap_and_Cp_w_Def(
 232               AP : C392010_0.Access_Procedure := C392010_0.Proc_2'Access;
 233               Cp : Tagtype_Level_1 := A_Default_Value )
 234   is
 235   begin
 236     TCTouch.Touch('H');  --------------------------------------------------- H
 237     Ap.All( C392010_0.Tagtype_Level_0( Cp ) );
 238   end Proc_w_Ap_and_Cp_w_Def;
 239
 240   procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 ) is
 241   begin
 242     TCTouch.Touch('I');  --------------------------------------------------- I
 243     TCTouch.Touch(Cp_Ap.Ch_Item);  -- depends on the value passed ---------- ?
 244   end Proc_w_Cp_Ap;
 245
 246   function A_Default_Value return Tagtype_Level_1 is
 247   begin
 248     return ( Int_Item => 0, Ch_Item  => 'y' );  ---------------------------- y
 249   end A_Default_Value;
 250
 251   function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 )
 252            return Tagtype_Level_1 is
 253   begin
 254     TCTouch.Touch('J');  --------------------------------------------------- J
 255     TCTouch.Touch(Cp_Ap.Ch_Item);  -- depends on the value passed ---------- ?
 256     return ( Int_Item => 2, Ch_Item => 'd' );  ----------------------------- d
 257   end Func_w_Cp_Ap_and_Cr;
 258
 259   procedure Proc_w_Non( Cp_Ap    : access Tagtype_Level_1;
 260                         NonCp_Ap : access C392010_0.Tagtype_Level_0
 261                           := C392010_0.Level_0_Global_Object'Access ) is
 262   begin
 263     TCTouch.Touch('K');  --------------------------------------------------- K
 264     TCTouch.Touch(Cp_Ap.Ch_Item);  ----- depends on the value passed ------- ?
 265     TCTouch.Touch(NonCp_Ap.Ch_Item);  -- depends on the value passed ------- ?
 266   end Proc_w_Non;
 267
 268   Own_Item : aliased Tagtype_Level_1 := ( Int_Item => 3, Ch_Item => 'e' );
 269
 270   function Func_w_Non( Cp_Ap : access Tagtype_Level_1;
 271                     NonCp_Ap : access C392010_0.Tagtype_Level_0
 272                              := C392010_0.Level_0_Global_Object'Access )
 273            return Access_Tagtype_Level_1 is
 274   begin
 275     TCTouch.Touch('L');  --------------------------------------------------- L
 276     TCTouch.Touch(Cp_Ap.Ch_Item);  ----- depends on the value passed ------- ?
 277     TCTouch.Touch(NonCp_Ap.Ch_Item);  -- depends on the value passed ------- ?
 278     return Own_Item'Access;  ----------------------------------------------- e
 279   end Func_w_Non;
 280
 281 end C392010_1;
 282
 283
 284
 285 ----------------------------------------------------------------- C392010_2
 286
 287 with C392010_0;
 288 with C392010_1;
 289 package C392010_2 is
 290
 291   Lev2_Level_0_Global_Object : aliased C392010_0.Tagtype_Level_0
 292                         := ( Ch_Item => 'f' );  ---------------------------- f
 293
 294   type Tagtype_Level_2 is new C392010_1.Tagtype_Level_1 with record
 295     Another_Int_Item : Integer;
 296   end record;
 297
 298   type Access_Tagtype_Level_2 is access all Tagtype_Level_2;
 299
 300   -- the following procedures are inherited by the above declaration:
 301   --I   procedure Proc_1( P: Tagtype_Level_2 );
 302   --I
 303   --I   procedure Proc_2( P: Tagtype_Level_2 );
 304   --I
 305   --I   procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure;
 306   --I                               Cp : Tagtype_Level_2 );
 307   --I
 308   --I   procedure Proc_w_Ap_and_Cp_w_Def
 309   --I             (AP: C392010_0.Access_Procedure := C392010_0. Proc_2'Access;
 310   --I              CP: Tagtype_Level_2 := A_Default_Value );
 311   --I
 312   --I   procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_2 );
 313   --I
 314   --I   procedure Proc_w_Non( Cp_Ap    : access Tagtype_Level_2;
 315   --I                         NonCp_Ap : access C392010_0.Tagtype_Level_0
 316   --I                           := C392010_0.Level_0_Global_Object'Access );
 317
 318   -- the following functions become abstract due to the above declaration:
 319   --A   function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 )
 320   --A            return Tagtype_Level_2;
 321   --A
 322   --A   function A_Default_Value
 323   --A            return Access_Tagtype_Level_2;
 324
 325   -- so we override the interesting ones to check the objective:
 326 --     Check that a subprogram with parameters of distinct tagged types may
 327 --     be primitive for only one type (i.e. the other tagged types must be
 328 --     declared in other packages).  Check that the subprogram does not
 329 --     dispatch for the other type(s).
 330
 331   procedure Proc_w_Non( Cp_Ap    : access Tagtype_Level_2;
 332                         NonCp_Ap : access C392010_0.Tagtype_Level_0
 333                                    := Lev2_Level_0_Global_Object'Access );
 334
 335   function Func_w_Non( Cp_Ap : access Tagtype_Level_2;
 336                     NonCp_Ap : access C392010_0.Tagtype_Level_0
 337                                       := Lev2_Level_0_Global_Object'Access )
 338            return C392010_1.Access_Tagtype_Level_1;
 339
 340   -- and override the other abstract functions
 341   function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 )
 342            return Tagtype_Level_2;
 343
 344   function A_Default_Value return Tagtype_Level_2;
 345
 346 end C392010_2;
 347
 348 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 349
 350 with TCTouch;
 351 with Report;
 352 package body C392010_2 is
 353
 354   procedure Proc_w_Non( Cp_Ap    : access Tagtype_Level_2;
 355                           NonCp_Ap : access C392010_0.Tagtype_Level_0
 356                                    := Lev2_Level_0_Global_Object'Access ) is
 357   begin
 358     TCTouch.Touch('M');  --------------------------------------------------- M
 359     TCTouch.Touch(Cp_Ap.Ch_Item);  ----- depends on the value passed ------- ?
 360     TCTouch.Touch(NonCp_Ap.Ch_Item);  -- depends on the value passed ------- ?
 361   end Proc_w_Non;
 362
 363   function A_Default_Value return Tagtype_Level_2 is
 364   begin
 365      return ( Another_Int_Item | Int_Item => 0, Ch_Item  => 'x' );  -------- x
 366   end A_Default_Value;
 367
 368   Own : aliased Tagtype_Level_2
 369                  := ( Another_Int_Item | Int_Item => 4, Ch_Item => 'g' );
 370
 371   function Func_w_Non( Cp_Ap : access Tagtype_Level_2;
 372                              NonCp_Ap : access C392010_0.Tagtype_Level_0
 373                                       := Lev2_Level_0_Global_Object'Access )
 374            return C392010_1.Access_Tagtype_Level_1 is
 375   begin
 376     TCTouch.Touch('N');  --------------------------------------------------- N
 377     TCTouch.Touch(Cp_Ap.Ch_Item);  ----- depends on the value passed ------- ?
 378     TCTouch.Touch(NonCp_Ap.Ch_Item);  -- depends on the value passed ------- ?
 379     return Own'Access;  ---------------------------------------------------- g
 380   end Func_w_Non;
 381
 382   function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 )
 383            return Tagtype_Level_2 is
 384   begin
 385     TCTouch.Touch('P');  --------------------------------------------------- P
 386     TCTouch.Touch(Cp_Ap.Ch_Item);  ----- depends on the value passed ------- ?
 387     return ( Another_Int_Item | Int_Item => 5, Ch_Item => 'h' );  ---------- h
 388  end Func_w_Cp_Ap_and_Cr;
 389
 390 end C392010_2;
 391
 392
 393
 394 ------------------------------------------------------------------- C392010
 395
 396 with Report;
 397 with TCTouch;
 398 with C392010_0, C392010_1, C392010_2;
 399
 400 procedure C392010 is
 401
 402   type Access_Class_0 is access all C392010_0.Tagtype_Level_0'Class;
 403
 404   -- define an array of class-wide pointers:
 405   type Zero_Dispatch_List is array(Natural range <>) of Access_Class_0;
 406
 407   Item_0 : aliased C392010_0.Tagtype_Level_0 := ( Ch_Item  => 'k' );  ------ k
 408   Item_1 : aliased C392010_1.Tagtype_Level_1 := ( Ch_Item  => 'm',    ------ m
 409                                                   Int_Item => 1 );
 410   Item_2 : aliased C392010_2.Tagtype_Level_2 := ( Ch_Item  => 'n',    ------ n
 411                                                   Int_Item => 1,
 412                                                   Another_Int_Item => 1 );
 413
 414   Z: Zero_Dispatch_List(1..3) := (Item_0'Access,Item_1'Access,Item_2'Access);
 415
 416   procedure Subtest_1( Items: Zero_Dispatch_List ) is
 417     -- there is little difference between the actions for _1 and _2 in
 418     -- this subtest due to the nature of _2 inheriting most operations
 419     --
 420     -- this subtest checks operations available to Level_0'Class
 421   begin
 422     for I in Items'Range loop
 423
 424       C392010_0.Proc_w_Ap_and_Cp( C392010_0.Proc_1'Access, Items(I).all );
 425       -- CAk, GAm, GAn
 426       -- actual is class-wide, operation should dispatch
 427
 428       case I is  -- use defaults
 429         when 1 => C392010_0.Proc_w_Ap_and_Cp_w_Def;
 430                   -- DBz
 431         when 2 => C392010_1.Proc_w_Ap_and_Cp_w_Def;
 432                   -- HBy
 433         when 3 => null; -- Removed following pending resolution by ARG
 434                   -- (see AI-00239):
 435                   -- C392010_2.Proc_w_Ap_and_Cp_w_Def;
 436                   -- HBx
 437         when others => Report.Failed("Unexpected loop value");
 438       end case;
 439
 440       C392010_0.Proc_w_Ap_and_Cp_w_Def   -- override defaults
 441                 ( C392010_0.Proc_1'Access, Items(I).all );
 442       -- DAk, HAm, HAn
 443
 444       C392010_0.Proc_w_Cp_Ap( Items(I) );
 445       -- Ek, Im, In
 446
 447       -- function return value is controlling for procedure call
 448       C392010_0.Proc_w_Ap_and_Cp_w_Def( C392010_0.Proc_1'Access,
 449                                   C392010_0.Func_w_Cp_Ap_and_Cr( Items(I) ) );
 450       -- FkDAb, JmHAd, PnHAh
 451       -- note that the function evaluates first
 452
 453     end loop;
 454   end Subtest_1;
 455
 456 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 457
 458   type Access_Class_1 is access all C392010_1.Tagtype_Level_1'Class;
 459
 460   type One_Dispatch_List is array(Natural range <>) of Access_Class_1;
 461
 462   Object_1 : aliased C392010_1.Tagtype_Level_1 := ( Ch_Item  => 'p',   ----- p
 463                                                     Int_Item => 1 );
 464   Object_2 : aliased C392010_2.Tagtype_Level_2 := ( Ch_Item  => 'q',   ----- q
 465                                                     Int_Item => 1,
 466                                             Another_Int_Item => 1 );
 467
 468   D: One_Dispatch_List(1..2) := (Object_1'Access, Object_2'Access);
 469
 470   procedure Subtest_2( Items: One_Dispatch_List ) is
 471     -- this subtest checks operations available to Level_1'Class,
 472     -- specifically those operations that are not testable in subtest_1,
 473     -- the operations with parameters of the two tagged type objects.
 474   begin
 475     for I in Items'Range loop
 476
 477        C392010_1.Proc_w_Non(                               -- t_1,   t_2
 478          C392010_1.Func_w_Non( Items(I),
 479            C392010_0.Tagtype_Level_0(Z(I).all)'Access ),   -- Lpk    Nqm
 480            C392010_0.Tagtype_Level_0(Z(I+1).all)'Access ); -- Kem    Mgn
 481
 482     end loop;
 483   end Subtest_2;
 484
 485 begin  -- Main test procedure.
 486
 487   Report.Test ("C392010", "Check that a subprogram dispatches correctly " &
 488                           "with a controlling access parameter. " &
 489                           "Check that a subprogram dispatches correctly " &
 490                           "when it has access parameters that are not " &
 491                           "controlling. Check with and without default " &
 492                           "expressions" );
 493
 494   Subtest_1( Z );
 495
 496   -- Original result:
 497   --TCTouch.Validate( "CAkDBzDAkEkFkDAb"
 498   --                & "GAmHByHAmImJmHAd"
 499   --                & "GAnHBxHAnInPnHAh", "Subtest 1" );
 500
 501   -- Result pending resultion of AI-239:
 502   TCTouch.Validate( "CAkDBzDAkEkFkDAb"
 503                   & "GAmHByHAmImJmHAd"
 504                   & "GAnHAnInPnHAh", "Subtest 1" );
 505
 506   Subtest_2( D );
 507
 508   TCTouch.Validate( "LpkKem" & "NqmMgn", "Subtest 2" );
 509
 510   Report.Result;
 511
 512 end C392010;