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