URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [cc/] [cc50001.a] - Rev 816
Compare with Previous | Blame | View Log
-- CC50001.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, in an instance, each implicit declaration of a predefined
-- operator of a formal tagged private type declares a view of the
-- corresponding predefined operator of the actual type (even if the
-- operator has been overridden for the actual type). Check that the
-- body executed is determined by the type and tag of the operands.
--
-- TEST DESCRIPTION:
-- The formal tagged private type has an unknown discriminant part, and
-- is thus indefinite. This allows both definite and indefinite types
-- to be passed as actuals. For tagged types, definite implies
-- nondiscriminated, and indefinite implies discriminated (with known
-- or unknown discriminants).
--
-- Only nonlimited tagged types are tested, since equality operators
-- are not predefined for limited types.
--
-- A tagged type is passed as an actual to a generic formal tagged
-- private type. The tagged type overrides the predefined equality
-- operator. A subprogram within the generic calls the equality operator
-- of the formal type. In an instance, the equality operator denotes
-- a view of the predefined operator of the actual type, but the
-- call dispatches to the body of the overriding operator.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 21 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected expected result on
-- calls to "=" within the instance. Modified
-- commentary.
--
--!
package CC50001_0 is
type Count_Type is tagged record -- Nondiscriminated
Count : Integer := 0; -- tagged type.
end record;
function "="(Left, Right : Count_Type) -- User-defined
return Boolean; -- equality operator.
subtype Str_Len is Natural range 0 .. 100;
subtype Stu_ID is String (1 .. 5);
subtype Dept_ID is String (1 .. 4);
subtype Emp_ID is String (1 .. 9);
type Status is (Student, Faculty, Staff);
type Person_Type (Stat : Status; -- Discriminated
NameLen, AddrLen : Str_Len) is -- tagged type.
tagged record
Name : String (1 .. NameLen);
Address : String (1 .. AddrLen);
case Stat is
when Student =>
Student_ID : Stu_ID;
when Faculty =>
Department : Dept_ID;
when Staff =>
Employee_ID : Emp_ID;
end case;
end record;
function "="(Left, Right : Person_Type) -- User-defined
return Boolean; -- equality operator.
-- Testing entities: ------------------------------------------------
TC_Count_Item : constant Count_Type := (Count => 111);
TC_Person_Item : constant Person_Type :=
(Faculty, 18, 17, "Eccles, John Scott", "Popham House, Lee", "0931");
---------------------------------------------------------------------
end CC50001_0;
--===================================================================--
package body CC50001_0 is
function "="(Left, Right : Count_Type) return Boolean is
begin
return False; -- Return FALSE even if Left = Right.
end "=";
function "="(Left, Right : Person_Type) return Boolean is
begin
return False; -- Return FALSE even if Left = Right.
end "=";
end CC50001_0;
--===================================================================--
with CC50001_0; -- Tagged (actual) type declarations.
generic -- Generic stack abstraction.
type Item (<>) is tagged private; -- Formal tagged private type.
package CC50001_1 is
-- Simulate a generic stack abstraction. In a real application, the
-- second operand of Push might be of type Stack, and type Stack
-- would have at least one component (pointing to the top stack item).
type Stack is private;
procedure Push (I : in Item; TC_Check : out Boolean);
-- ... Other stack operations.
private
-- ... Stack and ancillary type declarations.
type Stack is record -- Artificial.
null;
end record;
end CC50001_1;
--===================================================================--
package body CC50001_1 is
-- For the sake of brevity, the implementation of Push is completely
-- artificial; the goal is to model a call of the equality operator within
-- the generic.
--
-- A real application might implement Push such that it does not add new
-- items to the stack if they are identical to the top item; in that
-- case, the equality operator would be called as part of an "if"
-- condition.
procedure Push (I : in Item; TC_Check : out Boolean) is
begin
TC_Check := not (I = I); -- Call user-defined "="; should
-- return FALSE. Negation of
-- result makes TC_Check TRUE.
end Push;
end CC50001_1;
--==================================================================--
with CC50001_0; -- Tagged (actual) type declarations.
with CC50001_1; -- Generic stack abstraction.
use CC50001_0; -- Overloaded "=" directly visible.
with Report;
procedure CC50001 is
package Count_Stacks is new CC50001_1 (CC50001_0.Count_Type);
package Person_Stacks is new CC50001_1 (CC50001_0.Person_Type);
User_Defined_Op_Called : Boolean;
begin
Report.Test ("CC50001", "Check that, in an instance, each implicit " &
"declaration of a primitive subprogram of a formal tagged " &
"private type declares a view of the corresponding " &
"predefined operator of the actual type (even if the " &
"operator has been overridden or hidden for the actual type)");
--
-- Test which "=" is called inside generic:
--
User_Defined_Op_Called := False;
Count_Stacks.Push (CC50001_0.TC_Count_Item,
User_Defined_Op_Called);
if not User_Defined_Op_Called then
Report.Failed ("User-defined ""="" not called inside generic for Count");
end if;
User_Defined_Op_Called := False;
Person_Stacks.Push (CC50001_0.TC_Person_Item,
User_Defined_Op_Called);
if not User_Defined_Op_Called then
Report.Failed ("User-defined ""="" not called inside generic " &
"for Person");
end if;
--
-- Test which "=" is called outside generic:
--
User_Defined_Op_Called := False;
User_Defined_Op_Called :=
not (CC50001_0.TC_Count_Item = CC50001_0.TC_Count_Item);
if not User_Defined_Op_Called then
Report.Failed ("User-defined ""="" not called outside generic "&
"for Count");
end if;
User_Defined_Op_Called := False;
User_Defined_Op_Called :=
not (CC50001_0.TC_Person_Item = CC50001_0.TC_Person_Item);
if not User_Defined_Op_Called then
Report.Failed ("User-defined ""="" not called outside generic "&
"for Person");
end if;
Report.Result;
end CC50001;