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