llvm-gcc-4.2/gcc/testsuite/ada/acats/tests/c8/c854002.a

-- 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;