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