gcc/testsuite/ada/acats/tests/c9/c940015.a

   1 -- C940015.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 -- TEST OBJECTIVE:
  27 --      Check that the component_declarations of a protected_operation
  28 --      are elaborated in the proper order.
  29 --
  30 -- TEST DESCRIPTION:
  31 --      A discriminated protected object is declared with some
  32 --      components that depend upon the discriminant and some that
  33 --      do not depend upon the discriminant.  All the components
  34 --      are initialized with a function call.  As a side-effect of
  35 --      the function call the parameter passed to the function is
  36 --      recorded in an elaboration order array.
  37 --      Two objects of the protected type are declared.  The
  38 --      elaboration order is recorded and checked against the
  39 --      expected order.
  40 --
  41 --
  42 -- CHANGE HISTORY:
  43 --      09 Jan 96   SAIC    Initial Version for 2.1
  44 --      09 Jul 96   SAIC    Addressed reviewer comments.
  45 --      13 Feb 97   PWB.CTA Removed doomed attempt to check per-object
  46 --                          constraint elaborations.
  47 --!
  48
  49
  50 with Report;
  51
  52 procedure C940015 is
  53     Verbose : constant Boolean := False;
  54     Do_Display : Boolean := Verbose;
  55
  56     type Index is range 0..10;
  57
  58     type List is array (1..10) of Integer;
  59     Last : Natural range 0 .. List'Last := 0;
  60     E_List : List := (others => 0);
  61
  62     function Elaborate (Id : Integer) return Index is
  63     begin
  64         Last := Last + 1;
  65         E_List (Last) := Id;
  66         if Verbose then
  67             Report.Comment ("Elaborating" & Integer'Image (Id));
  68         end if;
  69         return Index(Id mod 10);
  70     end Elaborate;
  71
  72     function Elaborate (Id, Per_Obj_Expr : Integer) return Index is
  73     begin
  74         return Elaborate (Id);
  75     end Elaborate;
  76
  77 begin
  78
  79     Report.Test ("C940015", "Check that the component_declarations of a" &
  80                             " protected object are elaborated in the" &
  81                             " proper order");
  82     declare
  83         -- an unprotected queue type
  84         type Storage is array (Index range <>) of Integer;
  85         type Queue (Size, Flag : Index := 1) is
  86             record
  87                 Head : Index := 1;
  88                 Tail : Index := 1;
  89                 Count : Index := 0;
  90                 Buffer : Storage (1..Size);
  91             end record;
  92
  93         -- protected group of queues type
  94         protected type Prot_Queues (Size : Index := Elaborate (104)) is
  95             procedure Clear;
  96             -- other needed procedures not provided at this time
  97         private
  98                -- elaborate at type elaboration
  99             Fixed_Queue_1    : Queue (3,
 100                                       Elaborate (105));
 101                -- elaborate at type elaboration
 102             Fixed_Queue_2    : Queue (6,
 103                                       Elaborate (107));
 104         end Prot_Queues;
 105         protected body Prot_Queues is
 106             procedure Clear is
 107             begin
 108                 Fixed_Queue_1.Count := 0;
 109                 Fixed_Queue_1.Head := 1;
 110                 Fixed_Queue_1.Tail := 1;
 111                 Fixed_Queue_2.Count := 0;
 112                 Fixed_Queue_2.Head := 1;
 113                 Fixed_Queue_2.Tail := 1;
 114             end Clear;
 115         end Prot_Queues;
 116
 117         PO1 : Prot_Queues(9);
 118         PO2 : Prot_Queues;
 119
 120         Expected_Elab_Order : List := (
 121            -- from the elaboration of the protected type Prot_Queues
 122            105, 107,
 123            -- from the unconstrained object PO2
 124            104,
 125            others => 0);
 126     begin
 127         for I in List'Range loop
 128             if E_List (I) /= Expected_Elab_Order (I) then
 129                 Report.Failed ("wrong elaboration order");
 130                 Do_Display := True;
 131             end if;
 132         end loop;
 133         if Do_Display then
 134             Report.Comment ("Expected  Actual");
 135             for I in List'Range loop
 136                 Report.Comment (
 137                    Integer'Image (Expected_Elab_Order(I)) &
 138                    Integer'Image (E_List(I)));
 139             end loop;
 140         end if;
 141
 142         -- make use of the protected objects
 143         PO1.Clear;
 144         PO2.Clear;
 145     end;
 146
 147     Report.Result;
 148
 149 end C940015;