gomp-20050608-branch/gcc/testsuite/ada/acats/tests/cc/cc50a02.a

   1 -- CC50A02.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 nonlimited tagged type may be passed as an actual to a
  28 --      formal (non-tagged) private type. Check that if the formal type has
  29 --      an unknown discriminant part, a class-wide type may also be passed as
  30 --      an actual.
  31 --
  32 -- TEST DESCRIPTION:
  33 --      A generic package declares a formal private type and defines a
  34 --      stack abstraction. Stacks are modeled as singly linked lists of
  35 --      pointers to elements. Pointers are used because the elements may
  36 --      be unconstrained.
  37 --
  38 --      A generic testing procedure pushes an item onto a stack, then views
  39 --      the item on top of the stack.
  40 --
  41 --      The formal private type has an unknown discriminant part, and
  42 --      is thus indefinite. This allows both definite and indefinite types
  43 --      (including class-wide types) to be passed as actuals. For tagged types,
  44 --      definite implies nondiscriminated, and indefinite implies discriminated
  45 --      (with known/unknown discriminants).
  46 --
  47 -- TEST FILES:
  48 --      The following files comprise this test:
  49 --
  50 --         FC50A00.A
  51 --      -> CC50A02.A
  52 --
  53 --
  54 -- CHANGE HISTORY:
  55 --      06 Dec 94   SAIC    ACVC 2.0
  56 --      10 Nov 95   SAIC    ACVC 2.0.1 fixes: Removed use of formal package
  57 --                          exception name in exception choice.
  58 --
  59 --!
  60
  61 generic        -- Generic stack abstraction.
  62    type Item (<>) is private;                   -- Formal private type.
  63 package CC50A02_0 is
  64
  65    type Stack is private;
  66
  67    procedure Push     (I : in Item; S : in out Stack);
  68    function  View_Top (S : Stack) return Item;
  69
  70    -- ...Other stack operations...
  71
  72    Stack_Empty : exception;
  73
  74 private
  75
  76    type Item_Ptr is access Item;
  77
  78    type Stack_Item;
  79    type Stack_Ptr is access Stack_Item;
  80
  81    type Stack_Item is record
  82       Item : Item_Ptr;
  83       Next : Stack_Ptr;
  84    end record;
  85
  86    type Stack is record
  87       Top  : Stack_Ptr := null;
  88       Size : Natural   := 0;
  89    end record;
  90
  91 end CC50A02_0;
  92
  93
  94      --==================================================================--
  95
  96
  97 package body CC50A02_0 is
  98
  99    -- Link NewItem in at the top of the stack.
 100
 101    procedure Push (I : in Item; S : in out Stack) is
 102       NewItem : Item_Ptr  := new Item'(I);
 103       Element : Stack_Ptr := new Stack_Item'(Item => NewItem, Next => S.Top);
 104    begin
 105       S.Top   := Element;
 106       S.Size  := S.Size + 1;
 107    end Push;
 108
 109
 110    -- Return (copy) of top item on stack. Do NOT remove from stack.
 111
 112    function View_Top (S : Stack) return Item is
 113    begin
 114       if S.Top = null then
 115          raise Stack_Empty;
 116       else
 117          return S.Top.Item.all;
 118       end if;
 119    end View_Top;
 120
 121 end CC50A02_0;
 122
 123
 124      --==================================================================--
 125
 126
 127 -- The formal package Stacker below is needed to gain access to the
 128 -- appropriate version of the "generic" type Stack. It is provided with an
 129 -- explicit actual part in order to restrict the packages that can be passed
 130 -- as actuals to those which have been instantiated with the same actuals
 131 -- which this generic procedure has been instantiated with.
 132
 133 with CC50A02_0;  -- Generic stack abstraction.
 134 generic
 135    type Item_Type (<>) is private;       -- Formal private type.
 136    with package Stacker is new CC50A02_0 (Item_Type);
 137 procedure CC50A02_1 (S : in out Stacker.Stack; I : in Item_Type);
 138
 139
 140      --==================================================================--
 141
 142 --
 143 -- This generic procedure performs all of the testing of the
 144 -- stack abstraction.
 145 --
 146
 147 with Report;
 148 procedure CC50A02_1 (S : in out Stacker.Stack; I : in Item_Type) is
 149 begin
 150    Stacker.Push (I, S);                    -- Push onto empty stack.
 151
 152    -- Calls to View_Top must initialize a declared object of type Item_Type
 153    -- because the type may be unconstrained.
 154
 155    declare
 156       Buffer : Item_Type := Stacker.View_Top (S);
 157    begin
 158       if Buffer /= I then
 159          Report.Failed ("   Expected item not on stack");
 160       end if;
 161    exception
 162       when Constraint_Error =>
 163          Report.Failed ("   Unexpected error: Tags of pushed and popped " &
 164                         "items don't match");
 165    end;
 166
 167
 168 exception
 169    when others =>
 170       Report.Failed ("   Unexpected error: Item not pushed onto stack");
 171 end CC50A02_1;
 172
 173
 174      --==================================================================--
 175
 176
 177 with FC50A00;   -- Tagged (actual) type declarations.
 178 with CC50A02_0; -- Generic stack abstraction.
 179 with CC50A02_1; -- Generic stack testing procedure.
 180
 181 with Report;
 182 procedure CC50A02 is
 183
 184    --
 185    -- Pass a nondiscriminated tagged actual:
 186    --
 187
 188    package   Count_Stacks  is new CC50A02_0 (FC50A00.Count_Type);
 189    procedure TC_Count_Test is new CC50A02_1 (FC50A00.Count_Type,
 190                                              Count_Stacks);
 191    Count_Stack : Count_Stacks.Stack;
 192
 193
 194    --
 195    -- Pass a discriminated tagged actual:
 196    --
 197
 198    package   Person_Stacks  is new CC50A02_0 (FC50A00.Person_Type);
 199    procedure TC_Person_Test is new CC50A02_1 (FC50A00.Person_Type,
 200                                               Person_Stacks);
 201    Person_Stack : Person_Stacks.Stack;
 202
 203
 204    --
 205    -- Pass a class-wide actual:
 206    --
 207
 208    package   People_Stacks  is new CC50A02_0 (FC50A00.Person_Type'Class);
 209    procedure TC_People_Test is new CC50A02_1 (FC50A00.Person_Type'Class,
 210                                               People_Stacks);
 211    People_Stack : People_Stacks.Stack;
 212
 213 begin
 214    Report.Test ("CC50A02", "Check that tagged actuals may be passed " &
 215                 "to a formal (nontagged) private type");
 216
 217    Report.Comment ("Testing definite tagged type..");
 218    TC_Count_Test  (Count_Stack,  FC50A00.TC_Count_Item);
 219
 220    Report.Comment ("Testing indefinite tagged type..");
 221    TC_Person_Test (Person_Stack, FC50A00.TC_Person_Item);
 222
 223    Report.Comment ("Testing class-wide type..");
 224    TC_People_Test (People_Stack, FC50A00.TC_VIPerson_Item);
 225
 226    Report.Result;
 227 end CC50A02;