Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c8/c854002.a @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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;