-- 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;