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