Subversion Repositories openrisc_me

-- C340001.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 user-defined equality operators are inherited by a

--      derived type except when the derived type is a nonlimited record

--      extension. In the latter case, ensure that the primitive

--      equality operation of the record extension compares any extended

--      components according to the predefined equality operators of the

--      component types.  Also check that the parent portion of the extended

--      type is compared using the user-defined equality operation of the

--      parent type.

--

-- TEST DESCRIPTION:

--      Declares a nonlimited tagged record and a limited tagged record

--      type, each in a separate package. A user-defined "=" operation is

--      defined for each type. Each type is extended with one new record

--      component added.

--

--      Objects are declared for each parent and extended types and are

--      assigned values. For the limited type, modifier operations defined

--      in the package are used to assign values.

--

--      To verify the use of the user-defined "=", values are assigned so

--      that predefined equality will return the opposite result if called.

--      Similarly, values are assigned to the extended type objects so that

--      one comparison will verify that the inherited components from the

--      parent are compared using the user-defined equality operation.

--

--      A second comparison sets the values of the inherited components to

--      be the same so that equality based on the extended component may be

--      verified. For the nonlimited type, the test for equality should

--      fail, as the "=" defined for this type should include testing

--      equality of the extended component. For the limited type, "=" of the

--      parent should be inherited as-is, so the test for equality should

--      succeed even though the records differ in the extended component.

--

--      A third package declares a discriminated tagged record. Equality

--      is user-defined and ignores the discriminant value. A type

--      extension is declared which also contains a discriminant. Since

--      an inherited discriminant may not be referenced other than in a

--      "new" discriminant, the type extension is also discriminated. The

--      discriminant is used as the constraint for the parent type.

--

--      A variant part is declared in the type extension based on the new

--      discriminant. Comparisons are made to confirm that the user-defined

--      equality operator is used to compare values of the type extension.

--      Two record objects are given values so that user-defined equality

--      for the parent portion of the record succeeds, but the variant

--      parts in the type extended object differ. These objects are checked

--      to ensure that they are not equal.

--

--

-- CHANGE HISTORY:

--      06 Dec 94   SAIC    ACVC 2.0

--      19 Dec 94   SAIC    Removed RM references from objective text.

--

--!

with Ada.Calendar;

package C340001_0 is

   type DB_Record is tagged record

      Key : Natural range 1 .. 9999;

      Data : String (1..10);

   end record;

   function "=" (L, R : in DB_Record) return Boolean;

   type Dated_Record is new DB_Record with record

      Retrieval_Time : Ada.Calendar.Time;

   end record;

end C340001_0;

package body C340001_0 is

   function "=" (L, R : in DB_Record) return Boolean is

   -- Key is ignored in determining equality of records

   begin

      return L.Data = R.Data;

   end "=";

end C340001_0;

package C340001_1 is

   type List_Contents is array (1..10) of Integer;

   type List is tagged limited record

      Length   : Natural range 0..10 := 0;

      Contents : List_Contents := (others => 0);

   end record;

   procedure Add_To (L : in out List; New_Value : in Integer);

   procedure Remove_From (L : in out List);

   function "=" (L, R : in List) return Boolean;

   subtype Revision_Mark is Character range 'A' .. 'Z';

   type Revisable_List is new List with record

      Revision : Revision_Mark := 'A';

   end record;

   procedure Revise (L : in out Revisable_List);

end C340001_1;

package body C340001_1 is

   -- Note: This is not a complete abstraction of a list. Exceptions

   -- are not defined and boundary checks are not made.

   procedure Add_To (L : in out List; New_Value : in Integer) is

   begin

      L.Length := L.Length + 1;

      L.Contents (L.Length) := New_Value;

   end Add_To;

   procedure Remove_From (L : in out List) is

   -- The list length is decremented. "Old" values are left in the

   -- array. They are overwritten when a new value is added.

   begin

      L.Length := L.Length - 1;

   end Remove_From;

   function "=" (L, R : in List) return Boolean is

   -- Two lists are equal if they are the same length and

   -- the component values within that length are the same.

   -- Values stored past the end of the list are ignored.

   begin

      return L.Length = R.Length

         and then L.Contents (1..L.Length) = R.Contents (1..R.Length);

   end "=";

   procedure Revise (L : in out Revisable_List) is

   begin

      L.Revision := Character'Succ (L.Revision);

   end Revise;

end C340001_1;

package C340001_2 is

   type Media is (Paper, Electronic);

   type Transaction (Medium : Media) is tagged record

      ID : Natural range 1000 .. 9999;

   end record;

   function "=" (L, R : in Transaction) return Boolean;

   type Authorization (Kind : Media) is new Transaction (Medium => Kind)

   with record

      case Kind is

      when Paper =>

         Signature_On_File : Boolean;

      when Electronic =>

        Paper_Backup   : Boolean; -- to retain opposing value

      end case;

   end record;

end C340001_2;

package body C340001_2 is

   function "=" (L, R : in Transaction) return Boolean is

   -- There may be electronic and paper copies of the same transaction.

   -- The ID uniquely identifies a transaction. The medium (stored in

   -- the discriminant) is ignored.

   begin

      return L.ID = R.ID;

   end "=";

end C340001_2;

with C340001_0; -- nonlimited tagged record declarations

with C340001_1; -- limited tagged record declarations

with C340001_2; -- tagged variant declarations

with Ada.Calendar;

with Report;

procedure C340001 is

   DB_Rec1 : C340001_0.DB_Record := (Key  => 1,

                                     Data => "aaaaaaaaaa");

   DB_Rec2 : C340001_0.DB_Record := (Key  => 55,

                                     Data => "aaaaaaaaaa");

   -- DB_Rec1  = DB_Rec2 using user-defined equality

   -- DB_Rec1 /= DB_Rec2 using predefined equality

   Some_Time : Ada.Calendar.Time :=

      Ada.Calendar.Time_Of (Month => 9, Day => 16, Year => 1993);

   Another_Time : Ada.Calendar.Time :=

      Ada.Calendar.Time_Of (Month => 9, Day => 19, Year => 1993);

   Dated_Rec1 : C340001_0.Dated_Record := (Key  => 2,

                                           Data => "aaaaaaaaaa",

                                           Retrieval_Time => Some_Time);

   Dated_Rec2 : C340001_0.Dated_Record := (Key  => 77,

                                           Data => "aaaaaaaaaa",

                                           Retrieval_Time => Some_Time);

   Dated_Rec3 : C340001_0.Dated_Record := (Key  => 77,

                                           Data => "aaaaaaaaaa",

                                           Retrieval_Time => Another_Time);

   -- Dated_Rec1  = Dated_Rec2 if DB_Record."=" used for parent portion

   -- Dated_Rec2 /= Dated_Rec3 if extended component is compared

   --    using Ada.Calendar.Time."="

   List1 : C340001_1.List;

   List2 : C340001_1.List;

   RList1 : C340001_1.Revisable_List;

   RList2 : C340001_1.Revisable_List;

   RList3 : C340001_1.Revisable_List;

   Current : C340001_2.Transaction (C340001_2.Paper) :=

      (C340001_2.Paper, 2001);

   Last    : C340001_2.Transaction (C340001_2.Electronic) :=

      (C340001_2.Electronic, 2001);

   -- Current  = Last using user-defined equality

   -- Current /= Last using predefined equality

   Approval1 : C340001_2.Authorization (C340001_2.Paper)

    := (Kind => C340001_2.Paper,

        ID => 1040,

        Signature_On_File => True);

   Approval2 : C340001_2.Authorization (C340001_2.Paper)

    := (Kind => C340001_2.Paper,

        ID => 2167,

        Signature_On_File => False);

   Approval3 : C340001_2.Authorization (C340001_2.Electronic)

    := (Kind => C340001_2.Electronic,

        ID => 2167,

        Paper_Backup => False);

   -- Approval1 /= Approval2 if user-defined equality extended with

   --    component equality.

   -- Approval2 /= Approval3 if differing variant parts checked

   -- Direct visibility to operator symbols

   use type C340001_0.DB_Record;

   use type C340001_0.Dated_Record;

   use type C340001_1.List;

   use type C340001_1.Revisable_List;

   use type C340001_2.Transaction;

   use type C340001_2.Authorization;

begin

   Report.Test ("C340001", "Inheritance of user-defined ""=""");

   -- Approval1 /= Approval2 if user-defined equality extended with

   --    component equality.

   -- Approval2 /= Approval3 if differing variant parts checked

   ---------------------------------------------------------------------

   -- Check that "=" and "/=" for the parent type call the user-defined

   -- operation

   ---------------------------------------------------------------------

   if not (DB_Rec1 = DB_Rec2) then

      Report.Failed ("Nonlimited tagged record: " &

                     "User-defined equality did not override predefined " &

                     "equality");

   end if;

   if DB_Rec1 /= DB_Rec2 then

      Report.Failed ("Nonlimited tagged record: " &

                     "User-defined equality did not override predefined " &

                     "inequality as well");

   end if;

   ---------------------------------------------------------------------

   -- Check that "=" and "/=" for the type extension use the user-defined

   -- equality operations from the parent to compare the inherited

   -- components

   ---------------------------------------------------------------------

   if not (Dated_Rec1 = Dated_Rec2) then

      Report.Failed ("Nonlimited tagged record: " &

                     "User-defined equality was not used to compare " &

                     "components inherited from parent");

   end if;

   if Dated_Rec1 /= Dated_Rec2 then

      Report.Failed ("Nonlimited tagged record: " &

                     "User-defined inequality was not used to compare " &

                     "components inherited from parent");

   end if;

   ---------------------------------------------------------------------

   -- Check that equality and inequality for the type extension incorporate

   -- the predefined equality operators for the extended component type

   ---------------------------------------------------------------------

   if Dated_Rec2 = Dated_Rec3 then

      Report.Failed ("Nonlimited tagged record: " &

                     "Record equality was not extended with component " &

                     "equality");

   end if;

   if not (Dated_Rec2 /= Dated_Rec3) then

      Report.Failed ("Nonlimited tagged record: " &

                     "Record inequality was not extended with component " &

                     "equality");

   end if;

   ---------------------------------------------------------------------

   C340001_1.Add_To (List1, 1);

   C340001_1.Add_To (List1, 2);

   C340001_1.Add_To (List1, 3);

   C340001_1.Remove_From (List1);

   C340001_1.Add_To (List2, 1);

   C340001_1.Add_To (List2, 2);

   -- List1 contents are (2, (1, 2, 3, 0, 0, 0, 0, 0, 0, 0))

   -- List2 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0))

   -- List1 = List2 using user-defined equality

   -- List1 /= List2 using predefined equality

   ---------------------------------------------------------------------

   -- Check that "=" and "/=" for the parent type call the user-defined

   -- operation

   ---------------------------------------------------------------------

   if not (List1 = List2) then

      Report.Failed ("Limited tagged record   : " &

                     "User-defined equality incorrectly implemented " );

   end if;

   if List1 /= List2 then

      Report.Failed ("Limited tagged record   : " &

                     "User-defined equality incorrectly implemented " );

   end if;

   ---------------------------------------------------------------------

   -- RList1 and RList2 are made equal but "different" by adding

   -- a nonzero value to RList1 then removing it. Removal updates

   -- the list Length only, not its contents. The two lists will be

   -- equal according to the defined list abstraction, but the records

   -- will contain differing component values.

   C340001_1.Add_To (RList1, 1);

   C340001_1.Add_To (RList1, 2);

   C340001_1.Add_To (RList1, 3);

   C340001_1.Remove_From (RList1);

   C340001_1.Add_To (RList2, 1);

   C340001_1.Add_To (RList2, 2);

   C340001_1.Add_To (RList3, 1);

   C340001_1.Add_To (RList3, 2);

   C340001_1.Revise (RList3);

   -- RList1 contents are (2, (1, 2, 3, 0, 0, 0, 0, 0, 0, 0), 'A')

   -- RList2 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0), 'A')

   -- RList3 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0), 'B')

   -- RList1 = RList2 if List."=" inherited

   -- RList2 /= RList3 if List."=" inherited and extended with Character "="

   ---------------------------------------------------------------------

   -- Check that "=" and "/=" are the user-defined operations inherited

   -- from the parent type.

   ---------------------------------------------------------------------

   if not (RList1 = RList2) then

      Report.Failed ("Limited tagged record   : " &

                     "User-defined equality was not inherited");

   end if;

   if RList1 /= RList2 then

      Report.Failed ("Limited tagged record   : " &

                     "User-defined inequality was not inherited");

   end if;

   ---------------------------------------------------------------------

   -- Check that "=" and "/=" for the type extension are NOT extended

   -- with the predefined equality operators for the extended component.

   -- A limited type extension should inherit the parent equality operation

   -- as is.

   ---------------------------------------------------------------------

   if not (RList2 = RList3) then

      Report.Failed ("Limited tagged record   : " &

                     "Inherited equality operation was extended with " &

                     "component equality");

   end if;

   if RList2 /= RList3 then

      Report.Failed ("Limited tagged record   : " &

                     "Inherited inequality operation was extended with " &

                     "component equality");

   end if;

   ---------------------------------------------------------------------

   -- Check that "=" and "/=" for the parent type call the user-defined

   -- operation

   ---------------------------------------------------------------------

   if not (Current = Last) then

      Report.Failed ("Variant record          : " &

                     "User-defined equality did not override predefined " &

                     "equality");

   end if;

   if Current /= Last then

      Report.Failed ("Variant record          : " &

                     "User-defined inequality did not override predefined " &

                     "inequality");

   end if;

   ---------------------------------------------------------------------

   -- Check that user-defined equality was incorporated and extended

   -- with equality of extended components.

   ---------------------------------------------------------------------

   if not (Approval1 /= Approval2) then

      Report.Failed ("Variant record          : " &

                     "Inequality was not extended with component " &

                     "inequality");

   end if;

   if Approval1 = Approval2 then

      Report.Failed ("Variant record          : " &

                     "Equality was not extended with component " &

                     "equality");

   end if;

   ---------------------------------------------------------------------

   -- Check that equality and inequality for the type extension

   -- succeed despite the presence of differing variant parts.

   ---------------------------------------------------------------------

   if Approval2 = Approval3 then

      Report.Failed ("Variant record          : " &

                     "Equality succeeded even though variant parts " &

                     "in type extension differ");

   end if;

   if not (Approval2 /= Approval3) then

      Report.Failed ("Variant record          : " &

                     "Inequality failed even though variant parts " &

                     "in type extension differ");

   end if;

   ---------------------------------------------------------------------

   Report.Result;

   ---------------------------------------------------------------------

end C340001;