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
72with F340A001;        -- Book definitions.
73package 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
87end C340A02_0;
88
89
90     --==================================================================--
91
92
93package 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
103end C340A02_0;
104
105
106     --==================================================================--
107
108
109with F340A001;        -- Book definitions.
110package 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
130end C340A02_1;
131
132
133     --==================================================================--
134
135
136-- Library-level instantiation. Actual parameter is record extension.
137
138with C340A02_0;  -- Extended book abstraction.
139with F340A000;   -- Singly-linked list abstraction.
140package C340A02_2 is new F340A000
141  (Parent_Type => C340A02_0.Detailed_Book_Type);
142
143
144     --==================================================================--
145
146
147with Report;
148
149with C340A02_0; -- Extended book abstraction.
150with C340A02_1; -- Raw book data.
151with C340A02_2; -- Instance.
152
153use  C340A02_0; -- Primitive operations of Detailed_Book_Type directly visible.
154use  C340A02_2; -- Operations inherited by Node_Type directly visible.
155
156procedure 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
204begin  -- 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
221end C340A02;
222