1-- C854002.A 2-- 3-- Grant of Unlimited Rights 4-- 5-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and 6-- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the 7-- software and documentation contained herein. Unlimited rights are 8-- defined in DFAR 252.227-7013(a)(19). By making this public release, 9-- the Government intends to confer upon all recipients unlimited rights 10-- equal to those held by the Government. These rights include rights to 11-- use, duplicate, release or disclose the released technical data and 12-- computer software in whole or in part, in any manner and for any purpose 13-- whatsoever, and to have or permit others to do so. 14-- 15-- DISCLAIMER 16-- 17-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR 18-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 19-- WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE 20-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 21-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A 22-- PARTICULAR PURPOSE OF SAID MATERIAL. 23--* 24-- 25-- OBJECTIVE 26-- Check the requirements of the new 8.5.4(8.A) from Technical 27-- Corrigendum 1 (originally discussed as AI95-00064). 28-- This paragraph requires an elaboration check on renamings-as-body: 29-- even if the body of the ultimately-called subprogram has been 30-- elaborated, the check should fail if the renaming-as-body 31-- itself has not yet been elaborated. 32-- 33-- TEST DESCRIPTION 34-- We declare two functions F and G, and ensure that they are 35-- elaborated before anything else, by using pragma Pure. Then we 36-- declare two renamings-as-body: the renaming of F is direct, and 37-- the renaming of G is via an access-to-function object. We call 38-- the renamings during elaboration, and check that they raise 39-- Program_Error. We then call them again after elaboration; this 40-- time, they should work. 41-- 42-- CHANGE HISTORY: 43-- 29 JUN 1999 RAD Initial Version 44-- 23 SEP 1999 RLB Improved comments, renamed, issued. 45-- 28 JUN 2002 RLB Added pragma Elaborate_All for Report. 46--! 47 48package C854002_1 is 49 pragma Pure; 50 -- Empty. 51end C854002_1; 52 53package C854002_1.Pure is 54 pragma Pure; 55 function F return String; 56 function G return String; 57end C854002_1.Pure; 58 59with C854002_1.Pure; 60package C854002_1.Renamings is 61 62 F_Result: constant String := C854002_1.Pure.F; -- Make sure we can call F. 63 function Renamed_F return String; 64 65 G_Result: constant String := C854002_1.Pure.G; 66 type String_Function is access function return String; 67 G_Pointer: String_Function := null; 68 -- Will be set to C854002_1.Pure.G'Access in the body. 69 function Renamed_G return String; 70 71end C854002_1.Renamings; 72 73package C854002_1.Caller is 74 75 -- These procedures call the renamings; when called during elaboration, 76 -- we pass Should_Fail => True, which checks that Program_Error is 77 -- raised. Later, we use Should_Fail => False. 78 79 procedure Call_Renamed_F(Should_Fail: Boolean); 80 procedure Call_Renamed_G(Should_Fail: Boolean); 81 82end C854002_1.Caller; 83 84with Report; use Report; pragma Elaborate_All (Report); 85with C854002_1.Renamings; 86package body C854002_1.Caller is 87 88 Some_Error: exception; 89 90 procedure Call_Renamed_F(Should_Fail: Boolean) is 91 begin 92 if Should_Fail then 93 begin 94 Failed(C854002_1.Renamings.Renamed_F); 95 raise Some_Error; 96 -- This raise statement is necessary, because the 97 -- Report package has a bug -- if Failed is called 98 -- before Test, then the failure is ignored, and the 99 -- test prints "PASSED". 100 -- Presumably, this raise statement will cause the 101 -- program to crash, thus avoiding the PASSED message. 102 exception 103 when Program_Error => 104 Comment("Program_Error -- OK"); 105 end; 106 else 107 if C854002_1.Renamings.F_Result /= C854002_1.Renamings.Renamed_F then 108 Failed("Bad result from renamed F"); 109 end if; 110 end if; 111 end Call_Renamed_F; 112 113 procedure Call_Renamed_G(Should_Fail: Boolean) is 114 begin 115 if Should_Fail then 116 begin 117 Failed(C854002_1.Renamings.Renamed_G); 118 raise Some_Error; 119 exception 120 when Program_Error => 121 Comment("Program_Error -- OK"); 122 end; 123 else 124 if C854002_1.Renamings.G_Result /= C854002_1.Renamings.Renamed_G then 125 Failed("Bad result from renamed G"); 126 end if; 127 end if; 128 end Call_Renamed_G; 129 130begin 131 -- At this point, the bodies of Renamed_F and Renamed_G have not yet 132 -- been elaborated, so calling them should raise Program_Error: 133 Call_Renamed_F(Should_Fail => True); 134 Call_Renamed_G(Should_Fail => True); 135end C854002_1.Caller; 136 137package body C854002_1.Pure is 138 139 function F return String is 140 begin 141 return "This is function F"; 142 end F; 143 144 function G return String is 145 begin 146 return "This is function G"; 147 end G; 148 149end C854002_1.Pure; 150 151with C854002_1.Pure; 152with C854002_1.Caller; pragma Elaborate(C854002_1.Caller); 153 -- This pragma ensures that this package body (Renamings) 154 -- will be elaborated after Caller, so that when Caller calls 155 -- the renamings during its elaboration, the renamings will 156 -- not have been elaborated (although what the rename have been). 157package body C854002_1.Renamings is 158 159 function Renamed_F return String renames C854002_1.Pure.F; 160 161 package Dummy is end; -- So we can insert statements here. 162 package body Dummy is 163 begin 164 G_Pointer := C854002_1.Pure.G'Access; 165 end Dummy; 166 167 function Renamed_G return String renames G_Pointer.all; 168 169end C854002_1.Renamings; 170 171with Report; use Report; 172with C854002_1.Caller; 173procedure C854002 is 174begin 175 Test("C854002", 176 "An elaboration check is performed for a call to a subprogram" 177 & " whose body is given as a renaming-as-body"); 178 179 -- By the time we get here, all library units have been elaborated, 180 -- so the following calls should not raise Program_Error: 181 C854002_1.Caller.Call_Renamed_F(Should_Fail => False); 182 C854002_1.Caller.Call_Renamed_G(Should_Fail => False); 183 184 Result; 185end C854002; 186