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

   1 -- CC51001.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 formal parameter of a generic package may be a formal
  28 --      derived type. Check that the formal derived type may have an unknown
  29 --      discriminant part. Check that the ancestor type in a formal derived
  30 --      type definition may be a tagged type, and that the actual parameter
  31 --      may be a descendant of the ancestor type. Check that the formal derived
  32 --      type belongs to the derivation class rooted at the ancestor type;
  33 --      specifically, that components of the ancestor type may be referenced
  34 --      within the generic. Check that if a formal derived subtype is
  35 --      indefinite then the actual may be either definite or indefinite.
  36 --
  37 -- TEST DESCRIPTION:
  38 --      Define a class of tagged types with a definite root type. Extend the
  39 --      root type with a discriminated component. Since discriminants of
  40 --      tagged types may not have defaults, the type is indefinite.
  41 --
  42 --      Extend the extension with a second discriminated component, but with
  43 --      a new discriminant part. Declare a generic package with a formal
  44 --      derived type using the root type of the class as ancestor, and an
  45 --      unknown discriminant part. Declare an operation in the generic which
  46 --      accesses the common component of types in the class.
  47 --
  48 --      In the main program, instantiate the generic with each type in the
  49 --      class and verify that the operation correctly accesses the common
  50 --      component.
  51 --
  52 --
  53 -- CHANGE HISTORY:
  54 --      06 Dec 94   SAIC    ACVC 2.0
  55 --
  56 --!
  57
  58 package CC51001_0 is  -- Root type for message class.
  59
  60    subtype Msg_String is String (1 .. 20);
  61
  62    type Msg_Type is tagged record                          -- Root type of
  63       Text : Msg_String := (others => ' ');                -- class (definite).
  64    end record;
  65
  66 end CC51001_0;
  67
  68
  69 -- No body for CC51001_0.
  70
  71
  72      --==================================================================--
  73
  74
  75 with CC51001_0;       -- Root type for message class.
  76 package CC51001_1 is  -- Extensions to message class.
  77
  78    subtype Source_Length is Natural range 0 .. 10;
  79
  80    type From_Msg_Type (SLen : Source_Length) is            -- Direct derivative
  81      new CC51001_0.Msg_Type with record                    -- of root type
  82       From : String (1 .. SLen);                           -- (indefinite).
  83    end record;
  84
  85    subtype Dest_Length is Natural range 0 .. 10;
  86
  87
  88
  89    type To_From_Msg_Type (DLen : Dest_Length) is           -- Indirect
  90      new From_Msg_Type (SLen => 10) with record            -- derivative of
  91       To : String (1 .. DLen);                             -- root type
  92    end record;                                             -- (indefinite).
  93
  94 end CC51001_1;
  95
  96
  97 -- No body for CC51001_1.
  98
  99
 100      --==================================================================--
 101
 102
 103 with CC51001_0;       -- Root type for message class.
 104 generic               -- I/O operations for message class.
 105    type Message_Type (<>) is new CC51001_0.Msg_Type with private;
 106 package CC51001_2 is
 107
 108    -- This subprogram contains an artificial result for testing purposes:
 109    -- the function returns the text of the message to the caller as a string.
 110
 111    function Print_Message (M : in Message_Type) return String;
 112
 113    -- ... Other operations.
 114
 115 end CC51001_2;
 116
 117
 118      --==================================================================--
 119
 120
 121 package body CC51001_2 is
 122
 123    -- The implementations of the operations below are purely artificial; the
 124    -- validity of their implementations in the context of the abstraction is
 125    -- irrelevant to the feature being tested.
 126
 127    function Print_Message (M : in Message_Type) return String is
 128    begin
 129       return M.Text;
 130    end Print_Message;
 131
 132 end CC51001_2;
 133
 134
 135      --==================================================================--
 136
 137
 138 with CC51001_0;  -- Root type for message class.
 139 with CC51001_1;  -- Extensions to message class.
 140 with CC51001_2;  -- I/O operations for message class.
 141
 142 with Report;
 143 procedure CC51001 is
 144
 145    -- Instantiate for various types in the class:
 146
 147    package Msgs   is new CC51001_2 (CC51001_0.Msg_Type);         -- Definite.
 148    package FMsgs  is new CC51001_2 (CC51001_1.From_Msg_Type);    -- Indefinite.
 149    package TFMsgs is new CC51001_2 (CC51001_1.To_From_Msg_Type); -- Indefinite.
 150
 151
 152
 153    Msg   : CC51001_0.Msg_Type         := (Text => "This is message #001");
 154    FMsg  : CC51001_1.From_Msg_Type    := (Text => "This is message #002",
 155                                           SLen => 2,
 156                                           From => "Me");
 157    TFMsg : CC51001_1.To_From_Msg_Type := (Text => "This is message #003",
 158                                           From => "You       ",
 159                                           DLen => 4,
 160                                           To   => "Them");
 161
 162    Expected_Msg   : constant String := "This is message #001";
 163    Expected_FMsg  : constant String := "This is message #002";
 164    Expected_TFMsg : constant String := "This is message #003";
 165
 166 begin
 167    Report.Test ("CC51001", "Check that the formal derived type may have " &
 168                 "an unknown discriminant part. Check that the ancestor " &
 169                 "type in a formal derived type definition may be a " &
 170                 "tagged type, and that the actual parameter may be any " &
 171                 "definite or indefinite descendant of the ancestor type");
 172
 173    if (Msgs.Print_Message (Msg) /= Expected_Msg) then
 174       Report.Failed ("Wrong result for definite root type");
 175    end if;
 176
 177    if (FMsgs.Print_Message (FMsg) /= Expected_FMsg) then
 178       Report.Failed ("Wrong result for direct indefinite derivative");
 179    end if;
 180
 181    if (TFMsgs.Print_Message (TFMsg) /= Expected_TFMsg) then
 182       Report.Failed ("Wrong result for Indirect indefinite derivative");
 183    end if;
 184
 185    Report.Result;
 186 end CC51001;