gcc/testsuite/ada/acats/tests/cc/cc51002.a

   1 -- CC51002.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, for formal derived tagged types, the formal parameter
  28 --      names and default expressions for a primitive subprogram in an
  29 --      instance are determined by the primitive subprogram of the ancestor
  30 --      type, but that the primitive subprogram body executed is that of the
  31 --      actual type.
  32 --
  33 -- TEST DESCRIPTION:
  34 --      Define a root tagged type in a library-level package and give it a
  35 --      primitive subprogram. Provide a default expression for a non-tagged
  36 --      parameter of the subprogram. Declare a library-level generic subprogram
  37 --      with a formal derived type using the root type as ancestor. Call
  38 --      the primitive subprogram of the root type using named association for
  39 --      the tagged parameter, and provide no actual for the defaulted
  40 --      parameter. Extend the root type in a second package and override the
  41 --      root type's subprogram with one which has different parameter names
  42 --      and no default expression for the non-tagged parameter. Instantiate
  43 --      the generic subprogram for each of the tagged types in the class and
  44 --      call the instances.
  45 --
  46 --
  47 -- CHANGE HISTORY:
  48 --      06 Dec 94   SAIC    ACVC 2.0
  49 --
  50 --!
  51
  52 package CC51002_0 is  -- Root message type and operations.
  53
  54    type Recipients is (None, Root, Sysop, Local, Remote);
  55
  56    type Msg_Type is tagged record                             -- Root type of
  57       Text : String (1 .. 10);                                -- class.
  58    end record;
  59
  60    function Send (Msg : in Msg_Type;                          -- Primitive
  61                   To  : Recipients := Local) return Boolean;  -- subprogram.
  62
  63    -- ...Other message operations.
  64
  65 end CC51002_0;
  66
  67
  68      --==================================================================--
  69
  70
  71 package body CC51002_0 is
  72
  73    -- The implementation of Send is purely artificial; the validity of
  74    -- its implementation in the context of the abstraction is irrelevant to
  75    -- the feature being tested.
  76
  77    function Send (Msg : in Msg_Type;
  78                   To  : Recipients := Local) return Boolean is
  79    begin
  80       return (Msg.Text = "Greetings!" and To = Local);
  81    end Send;
  82
  83 end CC51002_0;
  84
  85
  86      --==================================================================--
  87
  88
  89 with CC51002_0;  -- Root message type and operations.
  90 generic          -- Message class function.
  91    type Msg_Block is new CC51002_0.Msg_Type with private;
  92 function CC51002_1 (M : in Msg_Block) return Boolean;
  93
  94
  95      --==================================================================--
  96
  97
  98 function CC51002_1 (M : in Msg_Block) return Boolean is
  99    Okay : Boolean := False;
 100 begin
 101
 102    -- The call to Send below uses the ancestor type's parameter name, which
 103    -- should be legal even if the actual subprogram called does not have a
 104    -- parameter of that name. Furthermore, it uses the ancestor type's default
 105    -- expression for the second parameter, which should be legal even if the
 106    -- the actual subprogram called has no such default expression.
 107
 108    Okay := Send (Msg => M);
 109    -- ...Other processing.
 110    return Okay;
 111
 112 end CC51002_1;
 113
 114
 115      --==================================================================--
 116
 117
 118 with CC51002_0;       -- Root message type and operations.
 119 package CC51002_2 is  -- Extended message type and operations.
 120
 121    type Sender_Type is (Inside, Outside);
 122
 123    type Who_Msg_Type is new CC51002_0.Msg_Type with record   -- Derivative of
 124       From : Sender_Type;                                    -- root type of
 125    end record;                                               -- class.
 126
 127
 128    -- Note: this overriding version of Send has different parameter names
 129    -- from the root type's function. It also has no default expression.
 130
 131    function Send (M : Who_Msg_Type;                          -- Overrides
 132                   R : CC51002_0.Recipients) return Boolean;  -- root type's
 133                                                              -- operation.
 134    -- ...Other extended message operations.
 135
 136 end CC51002_2;
 137
 138
 139      --==================================================================--
 140
 141
 142 package body CC51002_2 is
 143
 144    -- The implementation of Send is purely artificial; the validity of
 145    -- its implementation in the context of the abstraction is irrelevant to
 146    -- the feature being tested.
 147
 148    function Send (M : Who_Msg_Type; R : CC51002_0.Recipients) return Boolean is
 149       use type CC51002_0.Recipients;
 150    begin
 151       return (M.Text = "Willkommen"     and
 152               M.From = Outside          and
 153               R      = CC51002_0.Local);
 154    end Send;
 155
 156 end CC51002_2;
 157
 158
 159      --==================================================================--
 160
 161
 162 with CC51002_0;  -- Root message type and operations.
 163 with CC51002_1;  -- Message class function.
 164 with CC51002_2;  -- Extended message type and operations.
 165
 166 with Report;
 167 procedure CC51002 is
 168
 169    function Send_Msg  is new CC51002_1 (CC51002_0.Msg_Type);
 170    function Send_WMsg is new CC51002_1 (CC51002_2.Who_Msg_Type);
 171
 172    Mess  : CC51002_0.Msg_Type     := (Text => "Greetings!");
 173    WMess : CC51002_2.Who_Msg_Type := (Text => "Willkommen",
 174                                       From => CC51002_2.Outside);
 175
 176    TC_Okay_MStatus  : Boolean := False;
 177    TC_Okay_WMStatus : Boolean := False;
 178
 179 begin
 180    Report.Test ("CC51002", "Check that, for formal derived tagged types, " &
 181                 "the formal parameter names and default expressions for "  &
 182                 "a primitive subprogram in an instance are determined by " &
 183                 "the primitive subprogram of the ancestor type, but that " &
 184                 "the primitive subprogram body executed is that of the"    &
 185                 "actual type");
 186
 187    TC_Okay_MStatus := Send_Msg (Mess);
 188    if not TC_Okay_MStatus then
 189       Report.Failed ("Wrong result from call to root type's operation");
 190    end if;
 191
 192    TC_Okay_WMStatus := Send_WMsg (WMess);
 193    if not TC_Okay_WMStatus then
 194       Report.Failed ("Wrong result from call to derived type's operation");
 195    end if;
 196
 197    Report.Result;
 198 end CC51002;