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

   1 -- C340A01.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 tagged type declared in a package specification
  28 --      may be passed as a generic formal (tagged) private type to a generic
  29 --      package declaration. Check that the formal type may be extended with
  30 --      a record extension in the generic package.
  31 --
  32 --      Check that, in the instance, the record extension inherits the
  33 --      user-defined primitive subprograms of the tagged actual.
  34 --
  35 -- TEST DESCRIPTION:
  36 --      Declare a tagged type and an associated primitive subprogram in a
  37 --      package specification (foundation code). Declare a generic package
  38 --      which takes a tagged type as a formal parameter, and then extends
  39 --      it with a record extension (foundation code).
  40 --
  41 --      Instantiate the generic package with the tagged type from the first
  42 --      package (the "generic" extension should now have inherited
  43 --      the primitive subprogram of the tagged type from the first
  44 --      package).
  45 --
  46 --      In the main program, call the primitive subprogram inherited by the
  47 --      "generic" extension, and verify the correctness of the components.
  48 --
  49 -- TEST FILES:
  50 --      This test consists of the following files:
  51 --
  52 --         F340A000.A
  53 --         F340A001.A
  54 --      => C340A01.A
  55 --
  56 --
  57 -- CHANGE HISTORY:
  58 --      06 Dec 94   SAIC    ACVC 2.0
  59 --      12 Jun 96   SAIC    ACVC 2.1: Modified prologue. Removed extraneous
  60 --                          comments.
  61 --
  62 --!
  63
  64 with F340A001;        -- Book definitions.
  65 package C340A01_0 is  -- Raw data to be used in creating book elements.
  66
  67
  68    Book_Count : constant := 3;
  69
  70    subtype Number_Of_Books is Integer range 1 .. Book_Count;
  71
  72    type Data_List is array (Number_Of_Books) of F340A001.Text_Ptr;
  73
  74    Title_List  : Data_List := (new String'("Wuthering Heights"),
  75                                new String'("Heart of Darkness"),
  76                                new String'("Ulysses"));
  77
  78    Author_List : Data_List := (new String'("Bronte, Emily"),
  79                                new String'("Conrad, Joseph"),
  80                                new String'("Joyce, James"));
  81
  82 end C340A01_0;
  83
  84
  85      --==================================================================--
  86
  87
  88 -- Library-level instantiation. Actual parameter is tagged record.
  89
  90 with F340A001;  -- Book definitions.
  91 with F340A000;  -- Singly-linked list abstraction.
  92 package C340A01_1 is new F340A000 (Parent_Type => F340A001.Book_Type);
  93
  94
  95      --==================================================================--
  96
  97
  98 with Report;
  99
 100 with F340A001;   -- Book definitions.
 101 with C340A01_0;  -- Raw book data.
 102 with C340A01_1;  -- Instance.
 103
 104 use  F340A001;   -- Primitive operations of Book_Type directly visible.
 105 use  C340A01_1;  -- Operations inherited by Node_Type directly visible.
 106
 107 procedure C340A01 is
 108
 109
 110    List_Of_Books : Node_Ptr := null;  -- Head of linked list of books.
 111
 112
 113           --========================================================--
 114
 115
 116    procedure Create_List (Title, Author : in     C340A01_0.Data_List;
 117                           Head          : in out Node_Ptr) is
 118
 119       Book     : Node_Type;  -- Object of extended type.
 120       Book_Ptr : Node_Ptr;
 121
 122    begin
 123       for I in C340A01_0.Number_Of_Books loop
 124          Create_Book (Title (I), Author (I), Book);    -- Call inherited
 125                                                        -- operation.
 126          Book_Ptr := new Node_Type'(Book);
 127          Add (Book_Ptr, Head);
 128       end loop;
 129    end Create_List;
 130
 131
 132           --========================================================--
 133
 134
 135    function Bad_List_Contents return Boolean is
 136    begin
 137       return (List_Of_Books.Title.all            /= "Ulysses"           or
 138               List_Of_Books.Author.all           /= "Joyce, James"      or
 139               List_Of_Books.Next.Title.all       /= "Heart of Darkness" or
 140               List_Of_Books.Next.Author.all      /= "Conrad, Joseph"    or
 141               List_Of_Books.Next.Next.Title.all  /= "Wuthering Heights" or
 142               List_Of_Books.Next.Next.Author.all /= "Bronte, Emily");
 143    end Bad_List_Contents;
 144
 145
 146           --========================================================--
 147
 148
 149 begin  -- Main program.
 150
 151    Report.Test ("C340A01", "Inheritance of primitive operations: record " &
 152                 "extension of formal tagged private type; actual is " &
 153                 "an ultimate ancestor type");
 154
 155    -- Create linked list using inherited operation:
 156    Create_List (C340A01_0.Title_List, C340A01_0.Author_List, List_Of_Books);
 157
 158    -- Verify results:
 159    if Bad_List_Contents then
 160       Report.Failed ("Wrong values after call to inherited operation");
 161    end if;
 162
 163    Report.Result;
 164
 165 end C340A01;