old-autovect-branch/gcc/testsuite/ada/acats/tests/c9/c910003.a

   1 -- C910003.A
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
   6 --     F08630-91-C-0015, the U.S. Government obtained unlimited rights in the
   7 --     software and documentation contained herein.  Unlimited rights are
   8 --     defined in DFAR 252.227-7013(a)(19).  By making this public release,
   9 --     the Government intends to confer upon all recipients unlimited rights
  10 --     equal to those held by the Government.  These rights include rights to
  11 --     use, duplicate, release or disclose the released technical data and
  12 --     computer software in whole or in part, in any manner and for any purpose
  13 --     whatsoever, and to have or permit others to do so.
  14 --
  15 --                                    DISCLAIMER
  16 --
  17 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  18 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  19 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  20 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  21 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  22 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  23 --*
  24 --
  25 -- OBJECTIVE:
  26 --      Check that task discriminants that have an access subtype may be
  27 --      dereferenced.
  28 --
  29 --      Note that discriminants in Ada 83 never can be dereferenced with
  30 --      selection or indexing, as they cannot have an access type.
  31 --
  32 -- TEST DESCRIPTION:
  33 --      A protected object is defined to create a simple buffer.
  34 --      Two task types are defined, one to put values into the buffer,
  35 --      and one to remove them. The tasks are passed a buffer object as
  36 --      a discriminant with an access subtype. The producer task type includes
  37 --      a discriminant to determine the values to product. The consumer task
  38 --      type includes a value to save the results.
  39 --      Two producer and one consumer tasks are declared, and the results
  40 --      are checked.
  41 --
  42 -- CHANGE HISTORY:
  43 --      10 Mar 99   RLB    Created test.
  44 --
  45 --!
  46
  47 package C910003_Pack is
  48
  49     type Item_Type is range 1 .. 100; -- In a real application, this probably
  50                                       -- would be a record type.
  51
  52     type Item_Array is array (Positive range <>) of Item_Type;
  53
  54     protected type Buffer is
  55        entry Put (Item  : in Item_Type);
  56        entry Get (Item  : out Item_Type);
  57        function TC_Items_Buffered return Item_Array;
  58     private
  59        Saved_Item : Item_Type;
  60        Empty : Boolean := True;
  61        TC_Items : Item_Array (1 .. 10);
  62        TC_Last  : Natural := 0;
  63     end Buffer;
  64
  65     type Buffer_Access_Type is access Buffer;
  66
  67     PRODUCE_COUNT : constant := 2; -- Number of items to produce.
  68
  69     task type Producer (Buffer_Access : Buffer_Access_Type;
  70                         Start_At : Item_Type);
  71         -- Produces PRODUCE_COUNT items. Starts when activated.
  72
  73     type TC_Item_Array_Access_Type is access Item_Array (1 .. PRODUCE_COUNT*2);
  74
  75     task type Consumer (Buffer_Access : Buffer_Access_Type;
  76                         Results : TC_Item_Array_Access_Type) is
  77         -- Stores PRODUCE_COUNT*2 items consumed in Results. Starts when
  78         -- activated.
  79         entry Wait_until_Done;
  80     end Consumer;
  81
  82 end C910003_Pack;
  83
  84
  85 with Report;
  86 package body C910003_Pack is
  87
  88     protected body Buffer is
  89        entry Put (Item  : in Item_Type) when Empty is
  90        begin
  91            Empty := False;
  92            Saved_Item := Item;
  93            TC_Last := TC_Last + 1;
  94            TC_Items(TC_Last) := Item;
  95        end Put;
  96
  97        entry Get (Item  : out Item_Type) when not Empty is
  98        begin
  99            Empty := True;
 100            Item := Saved_Item;
 101        end Get;
 102
 103        function TC_Items_Buffered return Item_Array is
 104        begin
 105            return TC_Items(1..TC_Last);
 106        end TC_Items_Buffered;
 107
 108     end Buffer;
 109
 110
 111     task body Producer is
 112         -- Produces PRODUCE_COUNT items. Starts when activated.
 113     begin
 114         for I in 1 .. Report.Ident_Int(PRODUCE_COUNT) loop
 115            Buffer_Access.Put (Start_At + (Item_Type(I)-1)*2);
 116         end loop;
 117     end Producer;
 118
 119
 120     task body Consumer is
 121         -- Stores PRODUCE_COUNT*2 items consumed in Results. Starts when
 122         -- activated.
 123     begin
 124         for I in 1 .. Report.Ident_Int(PRODUCE_COUNT*2) loop
 125             Buffer_Access.Get (Results (I));
 126             -- Buffer_Access and Results are both dereferenced.
 127         end loop;
 128
 129         -- Check the results (and function call with a prefix dereference).
 130         if Results.all(Report.Ident_Int(1)) /= Buffer_Access.all.TC_Items_Buffered(Report.Ident_Int(1)) then
 131            Report.Failed ("First item mismatch");
 132         end if;
 133         if Results(Report.Ident_Int(2)) /= Buffer_Access.TC_Items_Buffered(Report.Ident_Int(2)) then
 134            Report.Failed ("Second item mismatch");
 135         end if;
 136         accept Wait_until_Done; -- Tell main that we're done.
 137     end Consumer;
 138
 139 end C910003_Pack;
 140
 141
 142 with Report;
 143 with C910003_Pack;
 144
 145 procedure C910003 is
 146
 147 begin -- C910003
 148
 149    Report.Test ("C910003", "Check that tasks discriminants of access types can be dereferenced");
 150
 151
 152    declare     -- encapsulate the test
 153
 154       Buffer_Access : C910003_Pack.Buffer_Access_Type :=
 155          new C910003_Pack.Buffer;
 156
 157       TC_Results : C910003_Pack.TC_Item_Array_Access_Type :=
 158          new C910003_Pack.Item_Array (1 .. C910003_Pack.PRODUCE_COUNT*2);
 159
 160       Producer_1 : C910003_Pack.Producer (Buffer_Access, 12);
 161       Producer_2 : C910003_Pack.Producer (Buffer_Access, 23);
 162
 163       Consumer : C910003_Pack.Consumer (Buffer_Access, TC_Results);
 164
 165       use type C910003_Pack.Item_Array; -- For /=.
 166
 167    begin
 168       Consumer.Wait_until_Done;
 169       if TC_Results.all /= Buffer_Access.TC_Items_Buffered then
 170            Report.Failed ("Different items buffered than returned - Main");
 171       end if;
 172       if (TC_Results.all /= (12, 14, 23, 25) and
 173           TC_Results.all /= (12, 23, 14, 25) and
 174           TC_Results.all /= (12, 23, 25, 14) and
 175           TC_Results.all /= (23, 12, 14, 25) and
 176           TC_Results.all /= (23, 12, 25, 14) and
 177           TC_Results.all /= (23, 25, 12, 14)) then
 178           -- Above are the only legal results.
 179            Report.Failed ("Wrong results");
 180       end if;
 181    end;     -- encapsulation
 182
 183    Report.Result;
 184
 185 end C910003;