diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c8/c854002.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c8/c854002.a | 185 |
1 files changed, 0 insertions, 185 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c8/c854002.a b/gcc/testsuite/ada/acats/tests/c8/c854002.a deleted file mode 100644 index 19bca35984e..00000000000 --- a/gcc/testsuite/ada/acats/tests/c8/c854002.a +++ /dev/null @@ -1,185 +0,0 @@ --- 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; |