1-- C854001.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 subprogram declaration can be completed by a 28-- subprogram renaming declaration. In particular, check that such a 29-- renaming-as-body can be given in a package body to complete a 30-- subprogram declared in the package specification. Check that calls 31-- to the subprogram invoke the body of the renamed subprogram. Check 32-- that a renaming allows a copy of an inherited or predefined subprogram 33-- before overriding it later. Check that renaming a dispatching 34-- operation calls the correct body in case of overriding. 35-- 36-- TEST DESCRIPTION: 37-- This test declares a record type, an integer type, and a tagged type 38-- with a set of operations in a package. A renaming of a predefined 39-- equality operation of a tagged type is also defined in this package. 40-- The predefined operation is overridden in the private part. In a 41-- separate package, a subtype of the record type and integer type 42-- are declared. Subset of the full set of operations for the record 43-- and types is reexported using renamings-as-bodies. Other operations 44-- are given explicit bodies. The test verifies that the appropriate 45-- body is executed for each operation on the subtype. 46-- 47-- 48-- CHANGE HISTORY: 49-- 06 Dec 94 SAIC ACVC 2.0 50-- 07 Nov 95 SAIC Update and repair for ACVC 2.0.1 51-- 52--! 53 54package C854001_0 is 55 56 type Component is (Op_Of_Type, Op_Of_Subtype, Initial_Value); 57 58 type Root is record 59 Called : Component := Op_Of_Subtype; 60 end record; 61 62 procedure Root_Proc (P: in out Root); 63 procedure Over_Proc (P: in out Root); 64 65 function Root_Func return Root; 66 function Over_Func return Root; 67 68 type Short_Int is range 1 .. 98; 69 70 function "+" (P1, P2 : Short_Int) return Short_Int; 71 function Name (P1, P2 : Short_Int) return Short_Int; 72 73 type Tag_Type is tagged record 74 C : Component := Initial_Value; 75 end record; 76 -- Inherits predefined operator "=" and others. 77 78 function Predefined_Equal (P1, P2 : Tag_Type) return Boolean 79 renames "="; 80 -- Renames predefined operator "=" before overriding. 81 82private 83 function "=" (P1, P2 : Tag_Type) 84 return Boolean; -- Overrides predefined operator "=". 85 86 87end C854001_0; 88 89 90 --==================================================================-- 91 92 93package body C854001_0 is 94 95 procedure Root_Proc (P: in out Root) is 96 begin 97 P.Called := Initial_Value; 98 end Root_Proc; 99 100 --------------------------------------- 101 procedure Over_Proc (P: in out Root) is 102 begin 103 P.Called := Op_Of_Type; 104 end Over_Proc; 105 106 --------------------------------------- 107 function Root_Func return Root is 108 begin 109 return (Called => Op_Of_Type); 110 end Root_Func; 111 112 --------------------------------------- 113 function Over_Func return Root is 114 begin 115 return (Called => Initial_Value); 116 end Over_Func; 117 118 --------------------------------------- 119 function "+" (P1, P2 : Short_Int) return Short_Int is 120 begin 121 return 15; 122 end "+"; 123 124 --------------------------------------- 125 function Name (P1, P2 : Short_Int) return Short_Int is 126 begin 127 return 47; 128 end Name; 129 130 --------------------------------------- 131 function "=" (P1, P2 : Tag_Type) return Boolean is 132 begin 133 return False; 134 end "="; 135 136end C854001_0; 137 138 --==================================================================-- 139 140 141with C854001_0; 142package C854001_1 is 143 144 subtype Root_Subtype is C854001_0.Root; 145 subtype Short_Int_Subtype is C854001_0.Short_Int; 146 147 procedure Ren_Proc (P: in out Root_Subtype); 148 procedure Same_Proc (P: in out Root_Subtype); 149 150 function Ren_Func return Root_Subtype; 151 function Same_Func return Root_Subtype; 152 153 function Other_Name (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype; 154 function "-" (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype; 155 156 function User_Defined_Equal (P1, P2 : C854001_0.Tag_Type) return Boolean 157 renames C854001_0."="; -- Executes body of the 158 -- overriding declaration in 159 -- the private part. 160end C854001_1; 161 162 163 --==================================================================-- 164 165 166with C854001_0; 167package body C854001_1 is 168 169 -- 170 -- Renaming-as-body for procedure: 171 -- 172 173 procedure Ren_Proc (P: in out Root_Subtype) 174 renames C854001_0.Root_Proc; 175 procedure Same_Proc (P: in out Root_Subtype) 176 renames C854001_0.Over_Proc; 177 178 -- 179 -- Renaming-as-body for function: 180 -- 181 182 function Ren_Func return Root_Subtype renames C854001_0.Root_Func; 183 function Same_Func return Root_Subtype renames C854001_0.Over_Func; 184 185 function Other_Name (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype 186 renames C854001_0."+"; 187 function "-" (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype 188 renames C854001_0.Name; 189 190end C854001_1; 191 192 193 --==================================================================-- 194 195with C854001_0; 196with C854001_1; -- Subtype and associated operations. 197use C854001_1; 198 199with Report; 200 201procedure C854001 is 202 Operand1 : Root_Subtype; 203 Operand2 : Root_Subtype; 204 Operand3 : Root_Subtype; 205 Operand4 : Root_Subtype; 206 Operand5 : Short_Int_Subtype := 55; 207 Operand6 : Short_Int_Subtype := 46; 208 Operand7 : Short_Int_Subtype; 209 Operand8 : C854001_0.Tag_Type; -- Both Operand8 & Operand9 have 210 Operand9 : C854001_0.Tag_Type; -- the same default values. 211 212 -- Direct visibility to operator symbols 213 use type C854001_0.Component; 214 use type C854001_0.Short_Int; 215 216begin 217 Report.Test ("C854001", "Check that a renaming-as-body can be given " & 218 "in a package body to complete a subprogram " & 219 "declared in the package specification. " & 220 "Check that calls to the subprogram invoke " & 221 "the body of the renamed subprogram"); 222 223 -- 224 -- Only operations of the subtype are available. 225 -- 226 227 Ren_Proc (Operand1); 228 if Operand1.Called /= C854001_0.Initial_Value then 229 Report.Failed ("Error calling procedure Ren_Proc"); 230 end if; 231 232 --------------------------------------- 233 Same_Proc (Operand2); 234 if Operand2.Called /= C854001_0.Op_Of_Type then 235 Report.Failed ("Error calling procedure Same_Proc"); 236 end if; 237 238 --------------------------------------- 239 Operand3 := Ren_Func; 240 if Operand3.Called /= C854001_0.Op_Of_Type then 241 Report.Failed ("Error calling function Ren_Func"); 242 end if; 243 244 --------------------------------------- 245 Operand4 := Same_Func; 246 if Operand4.Called /= C854001_0.Initial_Value then 247 Report.Failed ("Error calling function Same_Func"); 248 end if; 249 250 --------------------------------------- 251 Operand7 := C854001_1."-" (Operand5, Operand6); 252 if Operand7 /= 47 then 253 Report.Failed ("Error calling function & ""-"""); 254 end if; 255 256 --------------------------------------- 257 Operand7 := Other_Name (Operand5, Operand6); 258 if Operand7 /= 15 then 259 Report.Failed ("Error calling function Other_Name"); 260 end if; 261 262 --------------------------------------- 263 -- Executes body of the overriding declaration in the private part 264 -- of C854001_0. 265 if User_Defined_Equal (Operand8, Operand9) then 266 Report.Failed ("Error calling function User_Defined_Equal"); 267 end if; 268 269 --------------------------------------- 270 -- Executes predefined operation. 271 if not C854001_0.Predefined_Equal (Operand8, Operand9) then 272 Report.Failed ("Error calling function Predefined_Equal"); 273 end if; 274 275 Report.Result; 276 277end C854001; 278