1-- C392013.A 2-- 3-- Grant of Unlimited Rights 4-- 5-- The Ada Conformity Assessment Authority (ACAA) holds unlimited 6-- rights in the software and documentation contained herein. Unlimited 7-- rights are the same as those granted by the U.S. Government for older 8-- parts of the Ada Conformity Assessment Test Suite, and are defined 9-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA 10-- intends to confer upon all recipients unlimited rights equal to those 11-- held by the ACAA. These rights include rights to use, duplicate, 12-- release or disclose the released technical data and computer software 13-- in whole or in part, in any manner and for any purpose whatsoever, and 14-- to have or permit others to do so. 15-- 16-- DISCLAIMER 17-- 18-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR 19-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 20-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE 21-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 22-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A 23-- PARTICULAR PURPOSE OF SAID MATERIAL. 24--* 25-- 26-- OBJECTIVE: 27-- Check that the "/=" implicitly declared with the declaration of "=" for 28-- a tagged type is legal and can be used in a dispatching call. 29-- (Defect Report 8652/0010, as reflected in Technical Corrigendum 1). 30-- 31-- CHANGE HISTORY: 32-- 23 JAN 2001 PHL Initial version. 33-- 16 MAR 2001 RLB Readied for release; added identity and negative 34-- result cases. 35-- 24 MAY 2001 RLB Corrected the result for the 9 vs. 9 case. 36--! 37with Report; 38use Report; 39procedure C392013 is 40 41 package P1 is 42 type T is tagged 43 record 44 C1 : Integer; 45 end record; 46 function "=" (L, R : T) return Boolean; 47 end P1; 48 49 package P2 is 50 type T is new P1.T with private; 51 function Make (Ancestor : P1.T; X : Float) return T; 52 private 53 type T is new P1.T with 54 record 55 C2 : Float; 56 end record; 57 function "=" (L, R : T) return Boolean; 58 end P2; 59 60 package P3 is 61 type T is new P2.T with 62 record 63 C3 : Character; 64 end record; 65 private 66 function "=" (L, R : T) return Boolean; 67 function Make (Ancestor : P1.T; X : Float) return T; 68 end P3; 69 70 71 package body P1 is separate; 72 package body P2 is separate; 73 package body P3 is separate; 74 75 76 type Cwat is access P1.T'Class; 77 type Cwat_Array is array (Positive range <>) of Cwat; 78 79 A : constant Cwat_Array := 80 (1 => new P1.T'(C1 => Ident_Int (3)), 81 2 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (5)), X => 4.0)), 82 3 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (-5)), X => 4.2)), 83 4 => new P1.T'(C1 => Ident_Int (-3)), 84 5 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (5)), X => 3.6)), 85 6 => new P1.T'(C1 => Ident_Int (4)), 86 7 => new P3.T'(P2.Make 87 (Ancestor => (C1 => Ident_Int (4)), X => 1.2) with 88 Ident_Char ('a')), 89 8 => new P3.T'(P2.Make 90 (Ancestor => (C1 => Ident_Int (-4)), X => 1.3) with 91 Ident_Char ('A')), 92 9 => new P3.T'(P2.Make 93 (Ancestor => (C1 => Ident_Int (4)), X => 1.0) with 94 Ident_Char ('B'))); 95 96 type Truth is ('F', 'T'); 97 type Truth_Table is array (Positive range <>, Positive range <>) of Truth; 98 99 Equality : constant Truth_Table (A'Range, A'Range) := ("TFFTFFFFF", 100 "FTTFTFFFF", 101 "FTTFFFFFF", 102 "TFFTFFFFF", 103 "FTFFTFFFF", 104 "FFFFFTFFF", 105 "FFFFFFTTF", 106 "FFFFFFTTF", 107 "FFFFFFFFT"); 108 109begin 110 Test ("C392013", "Check that the ""/="" implicitly declared " & 111 "with the declaration of ""="" for a tagged " & 112 "type is legal and can be used in a dispatching call"); 113 114 for I in A'Range loop 115 for J in A'Range loop 116 -- Test identity: 117 if P1."=" (A (I).all, A (J).all) /= 118 (not P1."/=" (A (I).all, A (J).all)) then 119 Failed ("Incorrect identity comparing objects" & 120 Positive'Image (I) & " and" & Positive'Image (J)); 121 end if; 122 -- Test the result of "/=": 123 if Equality (I, J) = 'T' then 124 if P1."/=" (A (I).all, A (J).all) then 125 Failed ("Incorrect result comparing objects" & 126 Positive'Image (I) & " and" & Positive'Image (J) & " - T"); 127 end if; 128 else 129 if not P1."/=" (A (I).all, A (J).all) then 130 Failed ("Incorrect result comparing objects" & 131 Positive'Image (I) & " and" & Positive'Image (J) & " - F"); 132 end if; 133 end if; 134 end loop; 135 end loop; 136 137 Result; 138end C392013; 139separate (C392013) 140package body P1 is 141 142 function "=" (L, R : T) return Boolean is 143 begin 144 return abs L.C1 = abs R.C1; 145 end "="; 146 147end P1; 148separate (C392013) 149package body P2 is 150 151 function "=" (L, R : T) return Boolean is 152 begin 153 return P1."=" (P1.T (L), P1.T (R)) and then abs (L.C2 - R.C2) <= 0.5; 154 end "="; 155 156 157 function Make (Ancestor : P1.T; X : Float) return T is 158 begin 159 return (Ancestor with X); 160 end Make; 161 162end P2; 163with Ada.Characters.Handling; 164separate (C392013) 165package body P3 is 166 167 function "=" (L, R : T) return Boolean is 168 begin 169 return P2."=" (P2.T (L), P2.T (R)) and then 170 Ada.Characters.Handling.To_Upper (L.C3) = 171 Ada.Characters.Handling.To_Upper (R.C3); 172 end "="; 173 174 function Make (Ancestor : P1.T; X : Float) return T is 175 begin 176 return (P2.Make (Ancestor, X) with ' '); 177 end Make; 178 179end P3; 180