gcc/testsuite/ada/acats/tests/c7/c730a02.a

   1 -- C730A02.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 private extension (declared in a package specification) of
  28 --      a tagged type (declared in a different package specification) may be
  29 --      passed as a generic formal (tagged) private type to a generic package
  30 --      declaration. Check that the formal type may be further extended with a
  31 --      private extension in the generic package.
  32 --
  33 --      Check that the (visible) components inherited by the "generic"
  34 --      extension are visible outside the generic package.
  35 --
  36 --      Check that, in the instance, the private extension inherits the
  37 --      user-defined primitive subprograms of the tagged actual, including
  38 --      those inherited by the actual from its parent.
  39 --
  40 -- TEST DESCRIPTION:
  41 --      Declare a tagged type and an associated primitive subprogram in a
  42 --      package specification (foundation code). Declare a private extension
  43 --      of the tagged type and an associated primitive subprogram in a second
  44 --      package specification. Declare a generic package which takes a tagged
  45 --      type as a formal parameter, and then extends it with a private
  46 --      extension (foundation code).
  47 --
  48 --      Instantiate the generic package with the private extension from the
  49 --      second package (the "generic" extension should now have inherited
  50 --      the primitive subprograms of the private extension from the second
  51 --      package).
  52 --
  53 --      In the main program, call the primitive subprograms inherited by the
  54 --      "generic" extension. There are two: (1) Create_Book, declared for
  55 --      the root tagged type in the first package (inherited by the private
  56 --      extension of the second package, and then in turn by the "generic"
  57 --      extension), and (2) Update_Pages, declared for the private extension
  58 --      in the second package. Verify the correctness of the components.
  59 --
  60 -- TEST FILES:
  61 --      The following files comprise this test:
  62 --
  63 --         F730A000.A
  64 --         F730A001.A
  65 --      => C730A02.A
  66 --
  67 --
  68 -- CHANGE HISTORY:
  69 --      06 Dec 94   SAIC    ACVC 2.0
  70 --
  71 --!
  72
  73 with F730A001;        -- Book definitions.
  74 package C730A02_0 is  -- Extended book abstraction.
  75
  76
  77    type Detailed_Book_Type is new F730A001.Book_Type          -- Private ext.
  78      with private;                                            -- of root tagged
  79                                                               -- type.
  80
  81    -- Inherits Create_Book from Book_Type.
  82
  83    procedure Update_Pages (Book  : in out Detailed_Book_Type; -- Primitive op.
  84                            Pages : in     Natural);           -- of extension.
  85
  86
  87    -- The following function is needed to verify the value of the
  88    -- extension's private component. It will be inherited by extensions
  89    -- of Detailed_Book_Type.
  90
  91    function Get_Pages (Book : in Detailed_Book_Type) return Natural;
  92
  93 private
  94
  95    type Detailed_Book_Type is new F730A001.Book_Type with record
  96       Pages : Natural;
  97    end record;
  98
  99 end C730A02_0;
 100
 101
 102      --==================================================================--
 103
 104
 105 package body C730A02_0 is
 106
 107
 108    procedure Update_Pages (Book  : in out Detailed_Book_Type;
 109                            Pages : in     Natural) is
 110    begin
 111       Book.Pages := Pages;
 112    end Update_Pages;
 113
 114
 115    function Get_Pages (Book : in Detailed_Book_Type) return Natural is
 116    begin
 117       return (Book.Pages);
 118    end Get_Pages;
 119
 120
 121 end C730A02_0;
 122
 123
 124      --==================================================================--
 125
 126
 127 with F730A001;        -- Book definitions.
 128 package C730A02_1 is  -- Raw data to be used in creating book elements.
 129
 130
 131    Book_Count : constant := 3;
 132
 133    subtype Number_Of_Books is Integer range 1 .. Book_Count;
 134
 135    type Data_List   is array (Number_Of_Books) of F730A001.Text_Ptr;
 136    type Page_Counts is array (Number_Of_Books) of Natural;
 137
 138    Title_List  : Data_List   := (new String'("Wuthering Heights"),
 139                                  new String'("Heart of Darkness"),
 140                                  new String'("Ulysses"));
 141
 142    Author_List : Data_List   := (new String'("Bronte, Emily"),
 143                                  new String'("Conrad, Joseph"),
 144                                  new String'("Joyce, James"));
 145
 146    Page_List   : Page_Counts := (237, 215, 456);
 147
 148 end C730A02_1;
 149
 150
 151 -- No body for C730A02_1.
 152
 153
 154      --==================================================================--
 155
 156
 157 -- Library-level instantiation. Actual parameter is private extension.
 158
 159 with C730A02_0;  -- Extended book abstraction.
 160 with F730A000;   -- Singly-linked list abstraction.
 161 package C730A02_2 is new F730A000
 162   (Parent_Type => C730A02_0.Detailed_Book_Type);
 163
 164
 165      --==================================================================--
 166
 167
 168 with Report;
 169
 170 with C730A02_0; -- Extended book abstraction.
 171 with C730A02_1; -- Raw book data.
 172 with C730A02_2; -- Instance.
 173
 174 use  C730A02_0; -- Primitive operations of Detailed_Book_Type directly visible.
 175 use  C730A02_2; -- Operations inherited by Priv_Node_Type directly visible.
 176
 177 procedure C730A02 is
 178
 179
 180    List_Of_Books : Priv_Node_Ptr := null;  -- Head of linked list of books.
 181
 182
 183           --========================================================--
 184
 185
 186    procedure Create_List (Title, Author : in     C730A02_1.Data_List;
 187                           Pages         : in     C730A02_1.Page_Counts;
 188                           Head          : in out Priv_Node_Ptr) is
 189
 190       Book     : Priv_Node_Type;  -- Object of extended type.
 191       Book_Ptr : Priv_Node_Ptr;
 192
 193    begin
 194       for I in C730A02_1.Number_Of_Books loop
 195          Create_Book (Title (I), Author (I), Book);    -- Call twice-inherited
 196                                                        -- operation.
 197          Update_Pages (Book, Pages (I));               -- Call inherited op.
 198          Book_Ptr := new Priv_Node_Type'(Book);
 199          Add (Book_Ptr, Head);
 200       end loop;
 201    end Create_List;
 202
 203
 204           --========================================================--
 205
 206
 207    function Bad_List_Contents return Boolean is
 208       Book1_Ptr : Priv_Node_Ptr;
 209       Book2_Ptr : Priv_Node_Ptr;
 210       Book3_Ptr : Priv_Node_Ptr;
 211    begin
 212
 213       Remove (List_Of_Books, Book1_Ptr);
 214       Remove (List_Of_Books, Book2_Ptr);
 215       Remove (List_Of_Books, Book3_Ptr);
 216
 217       return (Book1_Ptr.Title.all   /= "Ulysses"           or   -- Inherited
 218               Book1_Ptr.Author.all  /= "Joyce, James"      or   -- components
 219               Book2_Ptr.Title.all   /= "Heart of Darkness" or   -- should still
 220               Book2_Ptr.Author.all  /= "Conrad, Joseph"    or   -- be visible
 221               Book3_Ptr.Title.all   /= "Wuthering Heights" or   -- in private
 222               Book3_Ptr.Author.all  /= "Bronte, Emily"     or   -- "generic"
 223                                                                 -- extension.
 224               -- Call inherited operations using dereferenced pointers.
 225               Get_Pages (Book1_Ptr.all) /= 456             or
 226               Get_Pages (Book2_Ptr.all) /= 215             or
 227               Get_Pages (Book3_Ptr.all) /= 237);
 228
 229    end Bad_List_Contents;
 230
 231
 232           --========================================================--
 233
 234
 235 begin  -- Main program.
 236
 237    Report.Test ("C730A02", "Inheritance of primitive operations: private " &
 238                 "extension of formal tagged private type; actual is " &
 239                 "a private extension");
 240
 241    -- Create linked list using inherited operation:
 242    Create_List (C730A02_1.Title_List, C730A02_1.Author_List,
 243                 C730A02_1.Page_List,  List_Of_Books);
 244
 245    -- Verify results:
 246    if Bad_List_Contents then
 247       Report.Failed ("Wrong values after call to inherited operations");
 248    end if;
 249
 250    Report.Result;
 251
 252 end C730A02;