1-- C3900011.AM
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 can be declared in the same package
28--      as its parent, and that this parent may be a tagged record or a
29--      record extension. Check that each derivative inherits all user-
30--      defined primitive subprograms of its parent (including those that
31--      its parent inherited), and that it may declare its own primitive
32--      subprograms.
33--
34--      Check that predefined equality operators are defined for the root
35--      tagged type.
36--
37--      Check that type conversion is defined from a type extension to its
38--      parent, and that this parent itself may be a type extension.
39--
40-- TEST DESCRIPTION:
41--      Declare a root tagged type in a package specification. Declare two
42--      primitive subprograms for the type.
43--
44--      Extend the root type with a record extension in the same package
45--      specification. Declare a new primitive subprogram for the extension
46--      (in addition to its two inherited subprograms).
47--
48--      Extend the extension with a record extension in the same package
49--      specification. Declare a new primitive subprogram for this second
50--      extension (in addition to its three inherited subprograms).
51--
52--      In the main program, declare operations for the root tagged type which
53--      utilize aggregates and equality operators to verify the correctness
54--      of the components. Overload these operations for the two type
55--      extensions. Within each of these overloading operations, utilize type
56--      conversion to call the parent's implementation of the same operation.
57--
58-- TEST FILES:
59--      The following files comprise this test:
60--
61--         C3900010.A
62--      => C3900011.AM
63--
64--
65-- CHANGE HISTORY:
66--      06 Dec 94   SAIC    ACVC 2.0
67--
68--!
69
70with C3900010;
71with Report;
72procedure C3900011 is
73
74
75   package Check_Alert_Values is
76
77      -- Declare functions to verify correctness of tagged record components
78      -- before and after calls to their primitive subprograms.
79
80
81      -- Alert_Type:
82
83      function Initial_Values_Okay (A : in C3900010.Alert_Type)
84        return Boolean;
85
86      function Bad_Final_Values (A : in C3900010.Alert_Type)
87        return Boolean;
88
89
90      -- Low_Alert_Type:
91
92      function Initial_Values_Okay (LA : in C3900010.Low_Alert_Type)
93        return Boolean;
94
95      function Bad_Final_Values (LA : in C3900010.Low_Alert_Type)
96        return Boolean;
97
98
99      -- Medium_Alert_Type:
100
101      function Initial_Values_Okay (MA : in C3900010.Medium_Alert_Type)
102        return Boolean;
103
104      function Bad_Final_Values (MA : in C3900010.Medium_Alert_Type)
105        return Boolean;
106
107
108   end Check_Alert_Values;
109
110
111        --==========================================================--
112
113
114   package body Check_Alert_Values is
115
116
117      function Initial_Values_Okay (A : in C3900010.Alert_Type)
118        return Boolean is
119         use type C3900010.Alert_Type;
120      begin                                      -- "=" operator availability.
121         return (A = (Arrival_Time => C3900010.Default_Time,
122                      Display_On   => C3900010.Null_Device));
123      end Initial_Values_Okay;
124
125
126      function Initial_Values_Okay (LA : in C3900010.Low_Alert_Type)
127        return Boolean is
128      begin                                      -- Type conversion.
129         return (Initial_Values_Okay (C3900010.Alert_Type (LA)) and
130                 LA.Level = 0);
131      end Initial_Values_Okay;
132
133
134      function Initial_Values_Okay (MA : in C3900010.Medium_Alert_Type)
135        return Boolean is
136         use type C3900010.Person_Enum;
137      begin                                      -- Type conversion.
138         return (Initial_Values_Okay (C3900010.Low_Alert_Type (MA)) and
139                 MA.Action_Officer = C3900010.Nobody);
140      end Initial_Values_Okay;
141
142
143      function Bad_Final_Values (A : in C3900010.Alert_Type)
144        return Boolean is
145         use type C3900010.Alert_Type;
146      begin                                      -- "/=" operator availability.
147         return (A /= (Arrival_Time => C3900010.Alert_Time,
148                       Display_On   => C3900010.Null_Device));
149      end Bad_Final_Values;
150
151
152      function Bad_Final_Values (LA : in C3900010.Low_Alert_Type)
153        return Boolean is
154         use type C3900010.Low_Alert_Type;
155      begin                                      -- "=" operator availability.
156         return not ( LA = (Arrival_Time => C3900010.Alert_Time,
157                            Display_On   => C3900010.Teletype,
158                            Level        => 1) );
159      end Bad_Final_Values;
160
161
162      function Bad_Final_Values (MA : in C3900010.Medium_Alert_Type)
163        return Boolean is
164         use type C3900010.Medium_Alert_Type;
165      begin                                      -- "/=" operator availability.
166         return ( MA /= (C3900010.Alert_Time,
167                         C3900010.Console,
168                         1,
169                         C3900010.Duty_Officer) );
170      end Bad_Final_Values;
171
172
173   end Check_Alert_Values;
174
175
176        --==========================================================--
177
178
179   use Check_Alert_Values;
180   use C3900010;
181
182   Root_Alarm   : C3900010.Alert_Type;
183   Low_Alarm    : C3900010.Low_Alert_Type;
184   Medium_Alarm : C3900010.Medium_Alert_Type;
185
186begin
187
188   Report.Test ("C390001", "Primitive operation inheritance by type " &
189                "extensions: all extensions declared in same package " &
190                "as parent");
191
192
193-- Check root tagged type:
194
195   if Initial_Values_Okay (Root_Alarm) then
196      Handle  (Root_Alarm);                          -- Explicitly declared.
197      Display (Root_Alarm);                          -- Explicitly declared.
198
199      if Bad_Final_Values (Root_Alarm) then
200         Report.Failed ("Wrong results after Alert_Type calls");
201      end if;
202   else
203      Report.Failed ("Wrong initial values for Alert_Type");
204   end if;
205
206
207-- Check record extension of root tagged type:
208
209   if Initial_Values_Okay (Low_Alarm) then
210      Handle (Low_Alarm);                            -- Inherited.
211      Low_Alarm.Display_On := Teletype;
212      Display (Low_Alarm);                           -- Inherited.
213      Low_Alarm.Level := Level_Of (Low_Alarm);       -- Explicitly declared.
214
215      if Bad_Final_Values (Low_Alarm) then
216         Report.Failed ("Wrong results after Low_Alert_Type calls");
217      end if;
218   else
219      Report.Failed ("Wrong initial values for Low_Alert_Type");
220   end if;
221
222
223-- Check record extension of record extension:
224
225   if Initial_Values_Okay (Medium_Alarm) then
226      Handle (Medium_Alarm);                         -- Inherited twice.
227      Medium_Alarm.Display_On := Console;
228      Display (Medium_Alarm);                        -- Inherited twice.
229      Medium_Alarm.Level := Level_Of (Medium_Alarm); -- Inherited.
230      Assign_Officer (Medium_Alarm, Duty_Officer);   -- Explicitly declared.
231
232      if Bad_Final_Values (Medium_Alarm) then
233         Report.Failed ("Wrong results after Medium_Alert_Type calls");
234      end if;
235   else
236      Report.Failed ("Wrong initial values for Medium_Alert_Type");
237   end if;
238
239
240-- Check final display counts:
241
242   if C3900010.Display_Count_For /= (Null_Device => 1,
243                                     Teletype    => 1,
244                                     Console     => 1,
245                                     Big_Screen  => 0)
246   then
247      Report.Failed ("Wrong final values for display counts");
248   end if;
249
250
251   Report.Result;
252
253end C3900011;
254