gomp-20050608-branch/gcc/testsuite/ada/acats/tests/c3/c392013.a

   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 --!
  37 with Report;
  38 use Report;
  39 procedure 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
 109 begin
 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;
 138 end C392013;
 139 separate (C392013)
 140 package 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
 147 end P1;
 148 separate (C392013)
 149 package 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
 162 end P2;
 163 with Ada.Characters.Handling;
 164 separate (C392013)
 165 package 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
 179 end P3;