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

   1 -- CC30001.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 if a non-overriding primitive subprogram is declared for
  28 --      a type derived from a formal derived tagged type, the copy of that
  29 --      subprogram in an instance can override a subprogram inherited from the
  30 --      actual type.
  31 --
  32 -- TEST DESCRIPTION:
  33 --      User writes program to handle both mail messages and system messages.
  34 --
  35 --      Mail messages are created by instantiating a generic "mail" package
  36 --      with a root message type. System messages are created by
  37 --      instantiating the generic with a system message type derived from the
  38 --      root in a separate package. The system message type has a primitive
  39 --      subprogram called Send.
  40 --
  41 --      Inside the generic, a "mail" type is derived from the generic formal
  42 --      derived type, and a "Send" operation is declared.
  43 --
  44 --      Declare a root tagged type T. Declare a generic package with a formal
  45 --      derived type using the root tagged type as ancestor. In the generic,
  46 --      derive a type from the formal derived type and declare a primitive
  47 --      subprogram for it. In a separate package, declare a derivative DT of
  48 --      the root tagged type T and declare a primitive subprogram which is
  49 --      type conformant with (and hence, overridable for) the primitive
  50 --      declared in the generic. Instantiate the generic for DT. Make both
  51 --      dispatching and non-dispatching calls to the primitive subprogram. In
  52 --      both cases the version of the subprogram in the instance should be
  53 --      called (since it overrides the implementation inherited from the
  54 --      actual).
  55 --
  56 --
  57 -- CHANGE HISTORY:
  58 --      06 Dec 94   SAIC    ACVC 2.0
  59 --      13 Apr 95   SAIC    Replaced call involving instance for root tagged
  60 --                          type with a dispatching call involving instance
  61 --                          for derived type. Updated commentary. Moved
  62 --                          instantiations (and related commentary) to
  63 --                          library-level to avoid accessibility violation.
  64 --                          Commented out instantiation for root tagged type.
  65 --      27 Feb 97   PWB.CTA Added elaboration pragma.
  66 --!
  67
  68 package CC30001_0 is  -- Root message type.
  69
  70    type Msg_Type is tagged record
  71       Text         : String (1 .. 20);
  72       Message_Sent : Boolean;
  73    end record;
  74
  75 end CC30001_0;
  76
  77
  78      --==================================================================--
  79
  80
  81 with CC30001_0;  -- Root message type.
  82 generic          -- Generic "mail" package.
  83    type Message is new CC30001_0.Msg_Type with private;
  84 package CC30001_1 is
  85
  86    type Mail_Type is new Message with record   -- Derived from formal type.
  87       To : String (1 .. 8);
  88    end record;
  89
  90    procedure Send (M : in out Mail_Type);      -- For this test, this version
  91                                                -- of Send should be called in
  92    -- ... Other operations.                    -- all cases.
  93
  94 end CC30001_1;
  95
  96
  97      --==================================================================--
  98
  99
 100 package body CC30001_1 is
 101
 102    procedure Send (M : in out Mail_Type) is
 103    begin
 104       -- ... Code to send message omitted for brevity.
 105       M.Message_Sent := True;
 106    end Send;
 107
 108 end CC30001_1;
 109
 110
 111      --==================================================================--
 112
 113
 114 with CC30001_0;       -- Root message type.
 115 package CC30001_2 is  -- System message type and operations.
 116
 117    type Signal_Type is (Note, Warning, Error);
 118
 119    type Sys_Message is new CC30001_0.Msg_Type with record   -- Derived from
 120       Signal : Signal_Type := Warning;                      -- root type.
 121    end record;
 122
 123    procedure Send (Item : in out Sys_Message); -- For this test, this version
 124                                                -- of Send should never be
 125    -- ... Other operations.                    -- called (it will have been
 126                                                -- overridden).
 127 end CC30001_2;
 128
 129
 130      --==================================================================--
 131
 132
 133 package body CC30001_2 is
 134
 135    procedure Send (Item : in out Sys_Message) is
 136    begin
 137       -- ... Code to send message omitted for brevity.
 138       Item.Message_Sent := False;  -- Ensure this procedure gives a different
 139    end Send;                       -- result than CC30001_1.Send.
 140
 141 end CC30001_2;
 142
 143
 144      --==================================================================--
 145
 146
 147 -- User first sets up support for mail messages by instantiating the
 148 -- generic mail package for the root message type. An operation "Send" is
 149 -- declared for the mail message type in the instance.
 150 --
 151 -- with CC30001_0;  -- Root message type.
 152 -- with CC30001_1;  -- Generic "mail" package.
 153 -- package Mail_Messages is new CC30001_1 (CC30001_0.Msg_Type);
 154
 155
 156      --==================================================================--
 157
 158
 159 -- Next, the user sets up support for system messages by instantiating the
 160 -- generic mail package with the system message type. An operation "Send"
 161 -- is declared for the "system" mail message type in the instance. This
 162 -- operation overrides the "Send" operation inherited from the system
 163 -- message type actual (a situation the user may not have intended).
 164
 165 with CC30001_1;  -- Generic "mail" package.
 166 with CC30001_2;  -- System message type and operations.
 167 pragma Elaborate (CC30001_1);
 168 package CC30001_3 is new CC30001_1 (CC30001_2.Sys_Message);
 169
 170
 171      --==================================================================--
 172
 173 with CC30001_2;  -- System message type and operations.
 174 with CC30001_3;  -- Instance with mail type and operations.
 175
 176 with Report;
 177 procedure CC30001 is
 178
 179    package System_Messages renames CC30001_3;
 180
 181
 182    Sys_Msg1 : System_Messages.Mail_Type := (Text   => "System shutting down",
 183                                             Signal => CC30001_2.Warning,
 184                                             To     => "AllUsers",
 185                                             Message_Sent => False);
 186
 187    Sys_Msg2 : System_Messages.Mail_Type'Class := Sys_Msg1;
 188
 189
 190    use System_Messages, CC30001_2;                 -- All versions of "Send"
 191                                                    -- directly visible.
 192
 193 begin
 194
 195    Report.Test ("CC30001", "Check that if a non-overriding primitive "     &
 196                 "subprogram is declared for a type derived from a formal " &
 197                 "derived tagged type, the copy of that subprogram in an "  &
 198                 "instance can override a subprogram inherited from the "   &
 199                 "actual type");
 200
 201
 202    Send (Sys_Msg1);   -- Calls version declared in instance (version declared
 203                       -- in CC30001_2 has been overridden).
 204
 205    if not Sys_Msg1.Message_Sent then
 206       Report.Failed ("Non-dispatching call: instance operation not called");
 207    end if;
 208
 209
 210    Send (Sys_Msg2);   -- Calls version declared in instance (version declared
 211                       -- in CC30001_2 has been overridden).
 212
 213    if not Sys_Msg2.Message_Sent then
 214       Report.Failed ("Dispatching call: instance operation not called");
 215    end if;
 216
 217
 218    Report.Result;
 219 end CC30001;