aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.9/gcc/testsuite/ada/acats/tests/cc/cc50001.a
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/cc/cc50001.a')
-rw-r--r--gcc-4.9/gcc/testsuite/ada/acats/tests/cc/cc50001.a257
1 files changed, 257 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cc/cc50001.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cc/cc50001.a
new file mode 100644
index 000000000..32a1afeb3
--- /dev/null
+++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cc/cc50001.a
@@ -0,0 +1,257 @@
+-- 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;