URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c8/] [c854002.a] - Rev 338
Compare with Previous | Blame | View Log
-- 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;