URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c4/] [c452001.a] - Rev 816
Compare with Previous | Blame | View Log
-- C452001.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:
-- For a type extension, check that predefined equality is defined in
-- terms of the primitive equals operator of the parent type and any
-- tagged components of the extension part.
--
-- For other composite types, check that the primitive equality operator
-- of any matching tagged components is used to determine equality of the
-- enclosing type.
--
-- For private types, check that predefined equality is defined in
-- terms of the user-defined (primitive) operator of the full type if
-- the full type is tagged. The partial view of the type may be
-- tagged or untagged. Check that predefined equality for a private
-- type whose full view is untagged is defined in terms of the
-- predefined equality operator of its full type.
--
-- TEST DESCRIPTION:
-- Tagged types are declared and used as components in several
-- differing composite type declarations, both tagged and untagged.
-- To differentiate between predefined and primitive equality
-- operations, user-defined equality operators are declared for
-- each component type that is to contribute to the equality
-- operator of the composite type that houses it. All user-defined
-- equality operations are designed to yield the opposite result
-- from the predefined operator, given the same component values.
--
-- For cases where primitive equality is to be incorporated into
-- equality for the enclosing composite type, values are assigned
-- to the component type so that user-defined equality will return
-- True. If predefined equality is to be used instead, then the
-- same strategy results in the equality operator returning False.
--
-- When equality for a type incorporates the user-defined equality
-- operator of one of its component types, the resulting operator
-- is considered to be the predefined operator of the composite type.
-- This case is confirmed by defining an tagged component of an
-- untagged composite type, then using the resulting untagged type
-- as a component of another composite type. The user-defined operator
-- for the lowest level should still be called.
--
-- Three cases are set up to test private types:
--
-- Case 1 Case 2 Case 3
-- partial view: tagged untagged untagged
-- full view: tagged tagged untagged
--
-- Types are declared for each of the above cases and user-defined
-- (primitive) operators are declared following the full type
-- declaration of each type (i.e., in the private part).
--
-- Values are assigned into objects of these types using the same
-- strategy outlined above. Cases 1 and 2 should execute the
-- user-defined operator. Case 3 should ignore the user-defined
-- operator and user predefined equality for the type.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 19 Dec 94 SAIC Removed RM references from objective text.
-- 15 Nov 95 SAIC Fixed for 2.0.1
-- 04 NOV 96 SAIC Typographical revision
--
--!
package c452001_0 is
type Point is
record
X : Integer := 0;
Y : Integer := 0;
end record;
type Circle is tagged
record
Center : Point;
Radius : Integer;
end record;
function "=" (L, R : Circle) return Boolean;
type Colors is (Red, Orange, Yellow, Green, Blue, Purple, Black, White);
type Colored_Circle is new Circle
with record
Color : Colors := White;
end record;
function "=" (L, R : Colored_Circle) return Boolean;
-- Override predefined equality for this tagged type. Predefined
-- equality should incorporate user-defined (primitive) equality
-- from type Circle. See C340001 for a test of that feature.
-- Equality is overridden to ensure that predefined equality
-- incorporates this user-defined function for
-- any composite type with Colored_Circle as a component type.
-- (i.e., the type extension is recognized as a tagged type for
-- the purpose of defining predefined equality for the composite type).
end C452001_0;
package body c452001_0 is
function "=" (L, R : Circle) return Boolean is
begin
return L.Radius = R.Radius; -- circles are same size
end "=";
function "=" (L, R : Colored_Circle) return Boolean is
begin
return Circle(L) = Circle(R);
end "=";
end C452001_0;
with C452001_0;
package C452001_1 is
type Planet is tagged record
Name : String (1..15);
Representation : C452001_0.Colored_Circle;
end record;
-- Type Planet will be used to check that predefined equality
-- for a tagged type with a tagged component incorporates
-- user-defined equality for the component type.
type TC_Planet is new Planet with null record;
-- A "copy" of Planet. Used to create a type extension. An "="
-- operator will be defined for this type that should be
-- incorporated by the type extension.
function "=" (Arg1, Arg2 : in TC_Planet) return Boolean;
type Craters is array (1..3) of C452001_0.Colored_Circle;
-- An array type (untagged) with tagged components
type Moon is new TC_Planet
with record
Crater : Craters;
end record;
-- A tagged record type. Extended component type is untagged,
-- but its predefined equality operator should incorporate
-- the user-defined operator of its tagged component type.
end C452001_1;
package body C452001_1 is
function "=" (Arg1, Arg2 : in TC_Planet) return Boolean is
begin
return Arg1.Name = Arg2.Name;
end "=";
end C452001_1;
package C452001_2 is
-- Untagged record types
-- Equality should not be incorporated
type Spacecraft_Design is (Mariner, Pioneer, Viking, Voyager);
type Spacecraft is record
Design : Spacecraft_Design;
Operational : Boolean;
end record;
function "=" (L : in Spacecraft; R : in Spacecraft) return Boolean;
type Mission is record
Craft : Spacecraft;
Launch_Date : Natural;
end record;
type Inventory is array (Positive range <>) of Spacecraft;
end C452001_2;
package body C452001_2 is
function "=" (L : in Spacecraft; R : in Spacecraft) return Boolean is
begin
return L.Design = R.Design;
end "=";
end C452001_2;
package C452001_3 is
type Tagged_Partial_Tagged_Full is tagged private;
procedure Change (Object : in out Tagged_Partial_Tagged_Full;
Value : in Boolean);
type Untagged_Partial_Tagged_Full is private;
procedure Change (Object : in out Untagged_Partial_Tagged_Full;
Value : in Integer);
type Untagged_Partial_Untagged_Full is private;
procedure Change (Object : in out Untagged_Partial_Untagged_Full;
Value : in Duration);
private
type Tagged_Partial_Tagged_Full is
tagged record
B : Boolean := True;
C : Character := ' ';
end record;
-- predefined equality checks that all components are equal
function "=" (L, R : in Tagged_Partial_Tagged_Full) return Boolean;
-- primitive equality checks that records equate in component C only
type Untagged_Partial_Tagged_Full is
tagged record
I : Integer := 0;
P : Positive := 1;
end record;
-- predefined equality checks that all components are equal
function "=" (L, R : in Untagged_Partial_Tagged_Full) return Boolean;
-- primitive equality checks that records equate in component P only
type Untagged_Partial_Untagged_Full is
record
D : Duration := 0.0;
S : String (1..12) := "Ada 9X rules";
end record;
-- predefined equality checks that all components are equal
function "=" (L, R : in Untagged_Partial_Untagged_Full) return Boolean;
-- primitive equality checks that records equate in component S only
end C452001_3;
with Report;
package body C452001_3 is
procedure Change (Object : in out Tagged_Partial_Tagged_Full;
Value : in Boolean) is
begin
Object := (Report.Ident_Bool(Value), Object.C);
end Change;
procedure Change (Object : in out Untagged_Partial_Tagged_Full;
Value : in Integer) is
begin
Object := (Report.Ident_Int(Value), Object.P);
end Change;
procedure Change (Object : in out Untagged_Partial_Untagged_Full;
Value : in Duration) is
begin
Object := (Value, Report.Ident_Str(Object.S));
end Change;
function "=" (L, R : in Tagged_Partial_Tagged_Full) return Boolean is
begin
return L.C = R.C;
end "=";
function "=" (L, R : in Untagged_Partial_Tagged_Full) return Boolean is
begin
return L.P = R.P;
end "=";
function "=" (L, R : in Untagged_Partial_Untagged_Full) return Boolean is
begin
return R.S = L.S;
end "=";
end C452001_3;
with C452001_0;
with C452001_1;
with C452001_2;
with C452001_3;
with Report;
procedure C452001 is
Mars_Aphelion : C452001_1.Planet :=
(Name => "Mars ",
Representation => (Center => (Report.Ident_Int(20),
Report.Ident_Int(0)),
Radius => Report.Ident_Int(4),
Color => C452001_0.Red));
Mars_Perihelion : C452001_1.Planet :=
(Name => "Mars ",
Representation => (Center => (Report.Ident_Int(-20),
Report.Ident_Int(0)),
Radius => Report.Ident_Int(4),
Color => C452001_0.Red));
-- Mars_Perihelion = Mars_Aphelion if user-defined equality from
-- the tagged type Colored_Circle was incorporated into
-- predefined equality for the tagged type Planet. User-defined
-- equality for Colored_Circle checks only that the Radii are equal.
Blue_Mars : C452001_1.Planet :=
(Name => "Mars ",
Representation => (Center => (Report.Ident_Int(10),
Report.Ident_Int(10)),
Radius => Report.Ident_Int(4),
Color => C452001_0.Blue));
-- Blue_Mars should equal Mars_Perihelion, because Names and
-- Radii are equal (all other components are not).
Green_Mars : C452001_1.Planet :=
(Name => "Mars ",
Representation => (Center => (Report.Ident_Int(10),
Report.Ident_Int(10)),
Radius => Report.Ident_Int(4),
Color => C452001_0.Green));
-- Blue_Mars should equal Green_Mars. They differ only in the
-- Color component. All user-defined equality operations return
-- True, but records are not equal by predefined equality.
-- Blue_Mars should equal Mars_Perihelion, because Names and
-- Radii are equal (all other components are not).
Moon_Craters : C452001_1.Craters :=
((Center => (Report.Ident_Int(9), Report.Ident_Int(11)),
Radius => Report.Ident_Int(1),
Color => C452001_0.Black),
(Center => (Report.Ident_Int(10), Report.Ident_Int(10)),
Radius => Report.Ident_Int(1),
Color => C452001_0.Black),
(Center => (Report.Ident_Int(11), Report.Ident_Int(9)),
Radius => Report.Ident_Int(1),
Color => C452001_0.Black));
Alternate_Moon_Craters : C452001_1.Craters :=
((Center => (Report.Ident_Int(9), Report.Ident_Int(9)),
Radius => Report.Ident_Int(1),
Color => C452001_0.Yellow),
(Center => (Report.Ident_Int(10), Report.Ident_Int(10)),
Radius => Report.Ident_Int(1),
Color => C452001_0.Purple),
(Center => (Report.Ident_Int(11), Report.Ident_Int(11)),
Radius => Report.Ident_Int(1),
Color => C452001_0.Purple));
-- Moon_Craters = Alternate_Moon_Craters if user-defined equality from
-- the tagged type Colored_Circle was incorporated into
-- predefined equality for the untagged type Craters. User-defined
-- equality checks only that the Radii are equal.
New_Moon : C452001_1.Moon :=
(Name => "Moon ",
Representation => (Center => (Report.Ident_Int(10),
Report.Ident_Int(8)),
Radius => Report.Ident_Int(3),
Color => C452001_0.Black),
Crater => Moon_Craters);
Full_Moon : C452001_1.Moon :=
(Name => "Moon ",
Representation => (Center => (Report.Ident_Int(10),
Report.Ident_Int(8)),
Radius => Report.Ident_Int(3),
Color => C452001_0.Black),
Crater => Alternate_Moon_Craters);
-- New_Moon = Full_Moon if user-defined equality from
-- the tagged type Colored_Circle was incorporated into
-- predefined equality for the untagged type Craters. This
-- equality test should call user-defined equality for type
-- TC_Planet (checks that Names are equal), then predefined
-- equality for Craters (ultimately calls user-defined equality
-- for type Circle, checking that Radii of craters are equal).
Mars_Moon : C452001_1.Moon :=
(Name => "Phobos ",
Representation => (Center => (Report.Ident_Int(10),
Report.Ident_Int(8)),
Radius => Report.Ident_Int(3),
Color => C452001_0.Black),
Crater => Alternate_Moon_Craters);
-- Mars_Moon /= Full_Moon since the Names differ.
Alternate_Moon_Craters_2 : C452001_1.Craters :=
((Center => (Report.Ident_Int(10), Report.Ident_Int(10)),
Radius => Report.Ident_Int(1),
Color => C452001_0.Red),
(Center => (Report.Ident_Int(9), Report.Ident_Int(9)),
Radius => Report.Ident_Int(1),
Color => C452001_0.Red),
(Center => (Report.Ident_Int(10), Report.Ident_Int(9)),
Radius => Report.Ident_Int(1),
Color => C452001_0.Red));
Harvest_Moon : C452001_1.Moon :=
(Name => "Moon ",
Representation => (Center => (Report.Ident_Int(11),
Report.Ident_Int(7)),
Radius => Report.Ident_Int(4),
Color => C452001_0.Orange),
Crater => Alternate_Moon_Craters_2);
-- Only the fields that are employed by the user-defined equality
-- operators are the same. Everything else differs. Equality should
-- still return True.
Viking_1_Orbiter : C452001_2.Mission :=
(Craft => (Design => C452001_2.Viking,
Operational => Report.Ident_Bool(False)),
Launch_Date => 1975);
Viking_1_Lander : C452001_2.Mission :=
(Craft => (Design => C452001_2.Viking,
Operational => Report.Ident_Bool(True)),
Launch_Date => 1975);
-- Viking_1_Orbiter /= Viking_1_Lander if predefined equality
-- from the untagged type Spacecraft is used for equality
-- of matching components in type Mission. If user-defined
-- equality for type Spacecraft is incorporated, which it
-- should not be by 4.5.2(21), then Viking_1_Orbiter = Viking_1_Lander.
Voyagers : C452001_2.Inventory (1..2):=
((C452001_2.Voyager, Operational => Report.Ident_Bool(True)),
(C452001_2.Voyager, Operational => Report.Ident_Bool(False)));
Jupiter_Craft : C452001_2.Inventory (1..2):=
((C452001_2.Voyager, Operational => Report.Ident_Bool(True)),
(C452001_2.Voyager, Operational => Report.Ident_Bool(True)));
-- Voyagers /= Jupiter_Craft if predefined equality
-- from the untagged type Spacecraft is used for equality
-- of matching components in type Inventory. If user-defined
-- equality for type Spacecraft is incorporated, which it
-- should not be by 4.5.2(21), then Voyagers = Jupiter_Craft.
TPTF_1 : C452001_3.Tagged_Partial_Tagged_Full;
TPTF_2 : C452001_3.Tagged_Partial_Tagged_Full;
-- With differing values for Boolean component, user-defined
-- (primitive) equality returns True, predefined equality
-- returns False. Since full type is tagged, primitive equality
-- should be used.
UPTF_1 : C452001_3.Untagged_Partial_Tagged_Full;
UPTF_2 : C452001_3.Untagged_Partial_Tagged_Full;
-- With differing values for Boolean component, user-defined
-- (primitive) equality returns True, predefined equality
-- returns False. Since full type is tagged, primitive equality
-- should be used.
UPUF_1 : C452001_3.Untagged_Partial_Untagged_Full;
UPUF_2 : C452001_3.Untagged_Partial_Untagged_Full;
-- With differing values for Duration component, user-defined
-- (primitive) equality returns True, predefined equality
-- returns False. Since full type is untagged, predefined equality
-- should be used.
-- Use type clauses make "=" and "/=" operators directly visible
use type C452001_1.Planet;
use type C452001_1.Craters;
use type C452001_1.Moon;
use type C452001_2.Mission;
use type C452001_2.Inventory;
use type C452001_3.Tagged_Partial_Tagged_Full;
use type C452001_3.Untagged_Partial_Tagged_Full;
use type C452001_3.Untagged_Partial_Untagged_Full;
begin
Report.Test ("C452001", "Equality of private types and " &
"composite types with tagged components");
-------------------------------------------------------------------
-- Tagged type with tagged component.
-------------------------------------------------------------------
if not (Mars_Aphelion = Mars_Perihelion) then
Report.Failed ("User-defined equality for tagged component " &
"was not incorporated into predefined equality " &
"for enclosing tagged record type");
end if;
if Mars_Aphelion /= Mars_Perihelion then
Report.Failed ("User-defined equality for tagged component " &
"was not incorporated into predefined inequality " &
"for enclosing tagged record type");
end if;
if not (Blue_Mars = Mars_Perihelion) then
Report.Failed ("Equality test for tagged record type " &
"incorporates record components " &
"other than those used by user-defined equality");
end if;
if Blue_Mars /= Mars_Perihelion then
Report.Failed ("Inequality test for tagged record type " &
"incorporates record components " &
"other than those used by user-defined equality");
end if;
if Blue_Mars /= Green_Mars then
Report.Failed ("Records are unequal even though they only differ " &
"in a component not used by user-defined equality");
end if;
if not (Blue_Mars = Green_Mars) then
Report.Failed ("Records are not equal even though they only differ " &
"in a component not used by user-defined equality");
end if;
-------------------------------------------------------------------
-- Untagged (array) type with tagged component.
-------------------------------------------------------------------
if not (Moon_Craters = Alternate_Moon_Craters) then
Report.Failed ("User-defined equality for tagged component " &
"was not incorporated into predefined equality " &
"for enclosing array type");
end if;
if Moon_Craters /= Alternate_Moon_Craters then
Report.Failed ("User-defined equality for tagged component " &
"was not incorporated into predefined inequality " &
"for enclosing array type");
end if;
-------------------------------------------------------------------
-- Tagged type with untagged composite component. Untagged
-- component itself has tagged components.
-------------------------------------------------------------------
if not (New_Moon = Full_Moon) then
Report.Failed ("User-defined equality for tagged component " &
"was not incorporated into predefined equality " &
"for array component of tagged record type");
end if;
if New_Moon /= Full_Moon then
Report.Failed ("User-defined equality for tagged component " &
"was not incorporated into predefined inequality " &
"for array component of tagged record type");
end if;
if Mars_Moon = Full_Moon then
Report.Failed ("User-defined equality for tagged component " &
"was not incorporated into predefined equality " &
"for array component of tagged record type");
end if;
if not (Mars_Moon /= Full_Moon) then
Report.Failed ("User-defined equality for tagged component " &
"was not incorporated into predefined inequality " &
"for array component of tagged record type");
end if;
if not (Harvest_Moon = Full_Moon) then
Report.Failed ("Equality test for record with array of tagged " &
"components incorporates record components " &
"other than those used by user-defined equality");
end if;
if Harvest_Moon /= Full_Moon then
Report.Failed ("Inequality test for record with array of tagged " &
"components incorporates record components " &
"other than those used by user-defined equality");
end if;
-------------------------------------------------------------------
-- Untagged types with no tagged components.
-------------------------------------------------------------------
-- Record type
if Viking_1_Orbiter = Viking_1_Lander then
Report.Failed ("User-defined equality for untagged composite " &
"component was incorporated into predefined " &
"equality for " &
"untagged record type");
end if;
if not (Viking_1_Orbiter /= Viking_1_Lander) then
Report.Failed ("User-defined equality for untagged composite " &
"component was incorporated into predefined " &
"inequality for " &
"untagged record type");
end if;
-- Array type
if Voyagers = Jupiter_Craft then
Report.Failed ("User-defined equality for untagged composite " &
"component was incorporated into predefined " &
"equality for " &
"array type");
end if;
if not (Voyagers /= Jupiter_Craft) then
Report.Failed ("User-defined equality for untagged composite " &
"component was incorporated into predefined " &
"inequality for " &
"array type");
end if;
-------------------------------------------------------------------
-- Private types tests.
-------------------------------------------------------------------
-- Make objects differ from one another
C452001_3.Change (TPTF_1, False);
C452001_3.Change (UPTF_1, 999);
C452001_3.Change (UPUF_1, 40.0);
-------------------------------------------------------------------
-- Partial type and full type are tagged. (Full type must be tagged
-- if partial type is tagged)
-------------------------------------------------------------------
if not (TPTF_1 = TPTF_2) then
Report.Failed ("Predefined equality for full type " &
"was used to determine equality of " &
"tagged private type " &
"instead of user-defined (primitive) equality");
end if;
if TPTF_1 /= TPTF_2 then
Report.Failed ("Predefined equality for full type " &
"was used to determine inequality of " &
"tagged private type " &
"instead of user-defined (primitive) equality");
end if;
-------------------------------------------------------------------
-- Partial type untagged, full type tagged.
-------------------------------------------------------------------
if not (UPTF_1 = UPTF_2) then
Report.Failed ("Predefined equality for full type " &
"was used to determine equality of " &
"private type (untagged partial view, " &
"tagged full view) " &
"instead of user-defined (primitive) equality");
end if;
if UPTF_1 /= UPTF_2 then
Report.Failed ("Predefined equality for full type " &
"was used to determine inequality of " &
"private type (untagged partial view, " &
"tagged full view) " &
"instead of user-defined (primitive) equality");
end if;
-------------------------------------------------------------------
-- Partial type and full type are both untagged.
-------------------------------------------------------------------
if UPUF_1 = UPUF_2 then
Report.Failed ("User-defined (primitive) equality for full type " &
"was used to determine equality of " &
"private type (untagged partial view, " &
"untagged full view) " &
"instead of predefined equality");
end if;
if not (UPUF_1 /= UPUF_2) then
Report.Failed ("User-defined (primitive) equality for full type " &
"was used to determine inequality of " &
"private type (untagged partial view, " &
"untagged full view) " &
"instead of predefined equality");
end if;
-------------------------------------------------------------------
Report.Result;
end C452001;