URL
https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk
Subversion Repositories openrisc_2011-10-31
[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c5/] [c540001.a] - Rev 384
Compare with Previous | Blame | View Log
-- C540001.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, 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 WHATSOEVER, 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 that an expression in a case statement may be of a generic formal
-- type. Check that a function call may be used as a case statement
-- expression. Check that a call to a generic formal function may be
-- used as a case statement expression. Check that a call to an inherited
-- function may be used as a case statement expression even if its result
-- type does not correspond to any nameable subtype.
--
-- TEST DESCRIPTION:
-- This transition test creates examples where expressions in a case
-- statement can be a generic formal object and a call to a generic formal
-- function. This test also creates examples when either a function call,
-- a renaming of a function, or a call to an inherited function is used
-- in the case expressions, the choices of the case statement only need
-- to cover the values in the result of the function.
--
-- Inspired by B54A08A.ADA.
--
--
-- CHANGE HISTORY:
-- 12 Feb 96 SAIC Initial version for ACVC 2.1.
--
--!
package C540001_0 is
type Int is range 1 .. 2;
end C540001_0;
--==================================================================--
with C540001_0;
package C540001_1 is
type Enum_Type is (Eh, Bee, Sea, Dee); -- Range of Enum_Type'Val is 0..3.
type Mixed is ('A','B', 'C', None);
subtype Small_Num is Natural range 0 .. 10;
type Small_Int is range 1 .. 2;
function Get_Small_Int (P : Boolean) return Small_Int;
procedure Assign_Mixed (P1 : in Boolean;
P2 : out Mixed);
type Tagged_Type is tagged
record
C1 : Enum_Type;
end record;
function Get_Tagged (P : Tagged_Type) return C540001_0.Int;
end C540001_1;
--==================================================================--
package body C540001_1 is
function Get_Small_Int (P : Boolean) return Small_Int is
begin
if P then
return Small_Int'First;
else
return Small_Int'Last;
end if;
end Get_Small_Int;
---------------------------------------------------------------------
procedure Assign_Mixed (P1 : in Boolean;
P2 : out Mixed) is
begin
case Get_Small_Int (P1) is -- Function call as expression
when 1 => P2 := None; -- in case statement.
when 2 => P2 := 'A';
-- No others needed.
end case;
end Assign_Mixed;
---------------------------------------------------------------------
function Get_Tagged (P : Tagged_Type) return C540001_0.Int is
begin
return C540001_0.Int'Last;
end Get_Tagged;
end C540001_1;
--==================================================================--
generic
type Formal_Scalar is range <>;
FSO : Formal_Scalar;
package C540001_2 is
type Enum is (Alpha, Beta, Theta);
procedure Assign_Enum (ET : out Enum);
end C540001_2;
--==================================================================--
package body C540001_2 is
procedure Assign_Enum (ET : out Enum) is
begin
case FSO is -- Type of expression in case
when 1 => ET := Alpha; -- statement is generic formal type.
when 2 => ET := Beta;
when others => ET := Theta;
end case;
end Assign_Enum;
end C540001_2;
--==================================================================--
with C540001_1;
generic
type Formal_Enum_Type is new C540001_1.Enum_Type;
with function Formal_Func (P : C540001_1.Small_Num)
return Formal_Enum_Type is <>;
function C540001_3 (P : C540001_1.Small_Num) return Formal_Enum_Type;
--==================================================================--
function C540001_3 (P : C540001_1.Small_Num) return Formal_Enum_Type is
begin
return Formal_Func (P);
end C540001_3;
--==================================================================--
with C540001_1;
generic
type Formal_Int_Type is new C540001_1.Small_Int;
with function Formal_Func return Formal_Int_Type;
package C540001_4 is
procedure Gen_Assign_Mixed (P : out C540001_1.Mixed);
end C540001_4;
--==================================================================--
package body C540001_4 is
procedure Gen_Assign_Mixed (P : out C540001_1.Mixed) is
begin
case Formal_Func is -- Case expression is
when 1 => P := C540001_1.'A'; -- generic function.
when others => P := C540001_1.'B';
end case;
end Gen_Assign_Mixed;
end C540001_4;
--==================================================================--
with C540001_1;
package C540001_5 is
type New_Tagged is new C540001_1.Tagged_Type with
record
C2 : C540001_1.Mixed;
end record;
-- Inherits Get_Tagged (P : New_Tagged) return C540001_0.Int;
-- Note that the return type of the inherited function is not
-- nameable here.
procedure Assign_Tagged (P1 : in New_Tagged;
P2 : out New_Tagged);
end C540001_5;
--==================================================================--
package body C540001_5 is
procedure Assign_Tagged (P1 : in New_Tagged;
P2 : out New_Tagged) is
begin
case Get_Tagged (P1) is -- Case expression is
-- inherited function.
when 2 => P2 := (C540001_1.Bee, 'B');
when others => P2 := (C540001_1.Sea, C540001_1.None);
end case;
end Assign_Tagged;
end C540001_5;
--==================================================================--
with Report;
with C540001_1;
with C540001_2;
with C540001_3;
with C540001_4;
with C540001_5;
procedure C540001 is
type Value is range 1 .. 5;
begin
Report.Test ("C540001", "Check that an expression in a case statement " &
"may be of a generic formal type. Check that a function " &
"call may be used as a case statement expression. Check " &
"that a call to a generic formal function may be used as " &
"a case statement expression. Check that a call to an " &
"inherited function may be used as a case statement " &
"expression");
Generic_Formal_Object_Subtest:
begin
declare
One : Value := 1;
package One_Pck is new C540001_2 (Value, One);
use One_Pck;
EObj : Enum;
begin
Assign_Enum (EObj);
if EObj /= Alpha then
Report.Failed ("Incorrect result for value of one in generic" &
"formal object subtest");
end if;
end;
declare
Five : Value := 5;
package Five_Pck is new C540001_2 (Value, Five);
use Five_Pck;
EObj : Enum;
begin
Assign_Enum (EObj);
if EObj /= Theta then
Report.Failed ("Incorrect result for value of five in generic" &
"formal object subtest");
end if;
end;
end Generic_Formal_Object_Subtest;
Instantiated_Generic_Function_Subtest:
declare
type New_Enum_Type is new C540001_1.Enum_Type;
function Get_Enum_Value (P : C540001_1.Small_Num)
return New_Enum_Type is
begin
return New_Enum_Type'Val (P);
end Get_Enum_Value;
function Val_Func is new C540001_3
(Formal_Enum_Type => New_Enum_Type,
Formal_Func => Get_Enum_Value);
procedure Assign_Num (P : in out C540001_1.Small_Num) is
begin
case Val_Func (P) is -- Case expression is
-- instantiated generic
when New_Enum_Type (C540001_1.Eh) | -- function.
New_Enum_Type (C540001_1.Sea) => P := 4;
when New_Enum_Type (C540001_1.Bee) => P := 7;
when others => P := 9;
end case;
end Assign_Num;
SNObj : C540001_1.Small_Num;
begin
SNObj := 0;
Assign_Num (SNObj);
if SNObj /= 4 then
Report.Failed ("Incorrect result for value of zero in call to " &
"generic function subtest");
end if;
SNObj := 3;
Assign_Num (SNObj);
if SNObj /= 9 then
Report.Failed ("Incorrect result for value of three in call to " &
"generic function subtest");
end if;
end Instantiated_Generic_Function_Subtest;
-- When a function call, a renaming of a function, or a call to an
-- inherited function is used in the case expressions, the choices
-- of the case statement only need to cover the values in the result
-- of the function.
Function_Call_Subtest:
declare
MObj : C540001_1.Mixed := 'B';
BObj : Boolean := True;
use type C540001_1.Mixed;
begin
C540001_1.Assign_Mixed (BObj, MObj);
if MObj /= C540001_1.None then
Report.Failed ("Incorrect result for value of true in function" &
"call subtest");
end if;
BObj := False;
C540001_1.Assign_Mixed (BObj, MObj);
if MObj /= C540001_1.'A' then
Report.Failed ("Incorrect result for value of false in function" &
"call subtest");
end if;
end Function_Call_Subtest;
Function_Renaming_Subtest:
declare
use C540001_1;
function Rename_Get_Small_Int (P : Boolean)
return Small_Int renames Get_Small_Int;
MObj : Mixed := None;
BObj : Boolean := False;
begin
case Rename_Get_Small_Int (BObj) is
when 1 => MObj := 'A';
when 2 => MObj := 'B';
-- No others needed.
end case;
if MObj /= 'B' then
Report.Failed ("Incorrect result for value of false in function" &
"renaming subtest");
end if;
end Function_Renaming_Subtest;
Call_To_Generic_Formal_Function_Subtest:
declare
type New_Small_Int is new C540001_1.Small_Int;
function Get_Int_Value return New_Small_Int is
begin
return New_Small_Int'First;
end Get_Int_Value;
package Int_Pck is new C540001_4
(Formal_Int_Type => New_Small_Int,
Formal_Func => Get_Int_Value);
use type C540001_1.Mixed;
MObj : C540001_1.Mixed := C540001_1.None;
begin
Int_Pck.Gen_Assign_Mixed (MObj);
if MObj /= C540001_1.'A' then
Report.Failed ("Incorrect result in call to generic formal " &
"function subtest");
end if;
end Call_To_Generic_Formal_Function_Subtest;
Call_To_Inherited_Function_Subtest:
declare
NTObj1 : C540001_5.New_Tagged := (C1 => C540001_1.Eh,
C2 => C540001_1.'A');
NTObj2 : C540001_5.New_Tagged := (C540001_1.Dee, C540001_1.'C');
use type C540001_1.Mixed;
use type C540001_1.Enum_Type;
begin
C540001_5.Assign_Tagged (NTObj1, NTObj2);
if NTObj2.C1 /= C540001_1.Bee or
NTObj2.C2 /= C540001_1.'B' then
Report.Failed ("Incorrect result in inherited function subtest");
end if;
end Call_To_Inherited_Function_Subtest;
Report.Result;
end C540001;