3 -- Grant of Unlimited Rights
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.
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.
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.
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.
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.
53 package C854002_1
.Pure
is
55 function F
return String;
56 function G
return String;
60 package C854002_1
.Renamings
is
62 F_Result
: constant String := C854002_1
.Pure
.F
; -- Make sure we can call F.
63 function Renamed_F
return String;
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;
71 end C854002_1
.Renamings
;
73 package C854002_1
.Caller
is
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.
79 procedure Call_Renamed_F
(Should_Fail
: Boolean);
80 procedure Call_Renamed_G
(Should_Fail
: Boolean);
84 with Report
; use Report
; pragma Elaborate_All
(Report
);
85 with C854002_1
.Renamings
;
86 package body C854002_1
.Caller
is
88 Some_Error
: exception;
90 procedure Call_Renamed_F
(Should_Fail
: Boolean) is
94 Failed
(C854002_1
.Renamings
.Renamed_F
);
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.
103 when Program_Error
=>
104 Comment
("Program_Error -- OK");
107 if C854002_1
.Renamings
.F_Result
/= C854002_1
.Renamings
.Renamed_F
then
108 Failed
("Bad result from renamed F");
113 procedure Call_Renamed_G
(Should_Fail
: Boolean) is
117 Failed
(C854002_1
.Renamings
.Renamed_G
);
120 when Program_Error
=>
121 Comment
("Program_Error -- OK");
124 if C854002_1
.Renamings
.G_Result
/= C854002_1
.Renamings
.Renamed_G
then
125 Failed
("Bad result from renamed G");
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
;
137 package body C854002_1
.Pure
is
139 function F
return String is
141 return "This is function F";
144 function G
return String is
146 return "This is function G";
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
159 function Renamed_F
return String renames C854002_1
.Pure
.F
;
161 package Dummy
is end; -- So we can insert statements here.
162 package body Dummy
is
164 G_Pointer
:= C854002_1
.Pure
.G
'Access;
167 function Renamed_G
return String renames G_Pointer
.all;
169 end C854002_1
.Renamings
;
171 with Report
; use Report
;
172 with C854002_1
.Caller
;
176 "An elaboration check is performed for a call to a subprogram"
177 & " whose body is given as a renaming-as-body");
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);