|
111
|
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
|
|
|
48 package C854002_1 is
|
|
|
49 pragma Pure;
|
|
|
50 -- Empty.
|
|
|
51 end C854002_1;
|
|
|
52
|
|
|
53 package C854002_1.Pure is
|
|
|
54 pragma Pure;
|
|
|
55 function F return String;
|
|
|
56 function G return String;
|
|
|
57 end C854002_1.Pure;
|
|
|
58
|
|
|
59 with C854002_1.Pure;
|
|
|
60 package 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
|
|
|
71 end C854002_1.Renamings;
|
|
|
72
|
|
|
73 package 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
|
|
|
82 end C854002_1.Caller;
|
|
|
83
|
|
|
84 with Report; use Report; pragma Elaborate_All (Report);
|
|
|
85 with C854002_1.Renamings;
|
|
|
86 package 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
|
|
|
130 begin
|
|
|
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);
|
|
|
135 end C854002_1.Caller;
|
|
|
136
|
|
|
137 package 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
|
|
|
149 end C854002_1.Pure;
|
|
|
150
|
|
|
151 with C854002_1.Pure;
|
|
|
152 with 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).
|
|
|
157 package 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
|
|
|
169 end C854002_1.Renamings;
|
|
|
170
|
|
|
171 with Report; use Report;
|
|
|
172 with C854002_1.Caller;
|
|
|
173 procedure C854002 is
|
|
|
174 begin
|
|
|
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;
|
|
|
185 end C854002;
|
