gcc/testsuite/ada/acats/tests/c3/c340a02.a

   1 -- C340A02.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 record 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 --      record extension in the generic package.
  32 --
  33 --      Check that, in the instance, the record extension inherits the
  34 --      user-defined primitive subprograms of the tagged actual, including
  35 --      those inherited by the actual from its parent.
  36 --
  37 -- TEST DESCRIPTION:
  38 --      Declare a tagged type and an associated primitive subprogram in a
  39 --      package specification (foundation code). Declare a record extension
  40 --      of the tagged type and an associated primitive subprogram in a second
  41 --      package specification. Declare a generic package which takes a tagged
  42 --      type as a formal parameter, and then extends it with a record
  43 --      extension (foundation code).
  44 --
  45 --      Instantiate the generic package with the record extension from the
  46 --      second package (the "generic" extension should now have inherited
  47 --      the primitive subprograms of the record extension from the second
  48 --      package).
  49 --
  50 --      In the main program, call the primitive subprograms inherited by the
  51 --      "generic" extension. There are two: (1) Create_Book, declared for
  52 --      the root tagged type in the first package (inherited by the record
  53 --      extension of the second package, and then in turn by the "generic"
  54 --      extension), and (2) Update_Pages, declared for the record extension
  55 --      in the second package. Verify the correctness of the components.
  56 --
  57 -- TEST FILES:
  58 --      This test consists of the following files:
  59 --
  60 --         F340A000.A
  61 --         F340A001.A
  62 --      => C340A02.A
  63 --
  64 --
  65 -- CHANGE HISTORY:
  66 --      06 Dec 94   SAIC    ACVC 2.0
  67 --      12 Jun 96   SAIC    ACVC 2.1: Modified prologue. Removed extraneous
  68 --                          comments.
  69 --
  70 --!
  71
  72 with F340A001;        -- Book definitions.
  73 package C340A02_0 is  -- Extended book abstraction.
  74
  75
  76    type Detailed_Book_Type is new F340A001.Book_Type with record
  77       Pages : Natural;                                        -- Record ext.
  78    end record;                                                -- 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 end C340A02_0;
  88
  89
  90      --==================================================================--
  91
  92
  93 package body C340A02_0 is
  94
  95
  96    procedure Update_Pages (Book  : in out Detailed_Book_Type;
  97                            Pages : in     Natural) is
  98    begin
  99       Book.Pages := Pages;
 100    end Update_Pages;
 101
 102
 103 end C340A02_0;
 104
 105
 106      --==================================================================--
 107
 108
 109 with F340A001;        -- Book definitions.
 110 package C340A02_1 is  -- Raw data to be used in creating book elements.
 111
 112
 113    Book_Count : constant := 3;
 114
 115    subtype Number_Of_Books is Integer range 1 .. Book_Count;
 116
 117    type Data_List   is array (Number_Of_Books) of F340A001.Text_Ptr;
 118    type Page_Counts is array (Number_Of_Books) of Natural;
 119
 120    Title_List  : Data_List   := (new String'("Wuthering Heights"),
 121                                  new String'("Heart of Darkness"),
 122                                  new String'("Ulysses"));
 123
 124    Author_List : Data_List   := (new String'("Bronte, Emily"),
 125                                  new String'("Conrad, Joseph"),
 126                                  new String'("Joyce, James"));
 127
 128    Page_List   : Page_Counts := (237, 215, 456);
 129
 130 end C340A02_1;
 131
 132
 133      --==================================================================--
 134
 135
 136 -- Library-level instantiation. Actual parameter is record extension.
 137
 138 with C340A02_0;  -- Extended book abstraction.
 139 with F340A000;   -- Singly-linked list abstraction.
 140 package C340A02_2 is new F340A000
 141   (Parent_Type => C340A02_0.Detailed_Book_Type);
 142
 143
 144      --==================================================================--
 145
 146
 147 with Report;
 148
 149 with C340A02_0; -- Extended book abstraction.
 150 with C340A02_1; -- Raw book data.
 151 with C340A02_2; -- Instance.
 152
 153 use  C340A02_0; -- Primitive operations of Detailed_Book_Type directly visible.
 154 use  C340A02_2; -- Operations inherited by Node_Type directly visible.
 155
 156 procedure C340A02 is
 157
 158
 159    List_Of_Books : Node_Ptr := null;  -- Head of linked list of books.
 160
 161
 162           --========================================================--
 163
 164
 165    procedure Create_List (Title, Author : in     C340A02_1.Data_List;
 166                           Pages         : in     C340A02_1.Page_Counts;
 167                           Head          : in out Node_Ptr) is
 168
 169       Book     : Node_Type;  -- Object of extended type.
 170       Book_Ptr : Node_Ptr;
 171
 172    begin
 173       for I in C340A02_1.Number_Of_Books loop
 174          Create_Book (Title (I), Author (I), Book);    -- Call twice-inherited
 175                                                        -- operation.
 176          Update_Pages (Book, Pages (I));               -- Call inherited op.
 177          Book_Ptr := new Node_Type'(Book);
 178          Add (Book_Ptr, Head);
 179       end loop;
 180    end Create_List;
 181
 182
 183           --========================================================--
 184
 185
 186    function Bad_List_Contents return Boolean is
 187    begin
 188       return (List_Of_Books.Title.all            /= "Ulysses"           or
 189               List_Of_Books.Author.all           /= "Joyce, James"      or
 190               List_Of_Books.Pages                /= 456                 or
 191               List_Of_Books.Next.Title.all       /= "Heart of Darkness" or
 192               List_Of_Books.Next.Author.all      /= "Conrad, Joseph"    or
 193               List_Of_Books.Next.Pages           /= 215                 or
 194               List_Of_Books.Next.Next.Title.all  /= "Wuthering Heights" or
 195               List_Of_Books.Next.Next.Author.all /= "Bronte, Emily"     or
 196               List_Of_Books.Next.Next.Pages      /= 237);
 197
 198    end Bad_List_Contents;
 199
 200
 201           --========================================================--
 202
 203
 204 begin  -- Main program.
 205
 206    Report.Test ("C340A02", "Inheritance of primitive operations: record " &
 207                 "extension of formal tagged private type; actual is " &
 208                 "a record extension");
 209
 210    -- Create linked list using inherited operation:
 211    Create_List (C340A02_1.Title_List, C340A02_1.Author_List,
 212                 C340A02_1.Page_List,  List_Of_Books);
 213
 214    -- Verify results:
 215    if Bad_List_Contents then
 216       Report.Failed ("Wrong values after call to inherited operations");
 217    end if;
 218
 219    Report.Result;
 220
 221 end C340A02;