gcc/testsuite/ada/acats/tests/c6/c67005c.ada

   1 -- C67005C.ADA
   2
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     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 -- CHECK THAT A DECLARATION OF "=" NEED NOT HAVE PARAMETERS
  26 -- OF A LIMITED TYPE IN A RENAMING DECLARATION. THIS TEST CHECKS
  27 -- ACCESS TYPES.
  28
  29 -- BRYCE BARDIN (HUGHES AIRCRAFT) 7/2/84
  30 -- CPP 7/12/84
  31
  32 WITH REPORT;  USE REPORT;
  33 PROCEDURE C67005C IS
  34
  35      GENERIC
  36           TYPE T IS LIMITED PRIVATE;
  37           WITH FUNCTION EQUAL (LEFT, RIGHT : T) RETURN BOOLEAN IS <>;
  38      PACKAGE EQUALITY IS
  39           FUNCTION "=" (LEFT, RIGHT : T) RETURN BOOLEAN;
  40           -- PRAGMA INLINE ("=");
  41      END EQUALITY;
  42
  43      PACKAGE BODY EQUALITY IS
  44           FUNCTION "=" (LEFT, RIGHT : T) RETURN BOOLEAN IS
  45           BEGIN
  46                RETURN EQUAL (LEFT, RIGHT);
  47           END "=";
  48      END EQUALITY;
  49
  50      PACKAGE STARTER IS
  51           TYPE INT IS PRIVATE;
  52           FUNCTION VALUE_OF (I : INTEGER) RETURN INT;
  53           FUNCTION EQUAL (LEFT, RIGHT : INT) RETURN BOOLEAN;
  54      PRIVATE
  55           TYPE INT IS ACCESS INTEGER;
  56      END STARTER;
  57
  58      PACKAGE BODY STARTER IS
  59           FUNCTION VALUE_OF (I : INTEGER) RETURN INT IS
  60           BEGIN
  61                RETURN NEW INTEGER'(I);
  62           END VALUE_OF;
  63
  64           FUNCTION EQUAL (LEFT, RIGHT : INT) RETURN BOOLEAN IS
  65           BEGIN
  66                RETURN LEFT.ALL = RIGHT.ALL;
  67           END EQUAL;
  68      END STARTER;
  69
  70      PACKAGE ABSTRACTION IS
  71           TYPE INT IS NEW STARTER.INT;
  72           PACKAGE INT_EQUALITY IS NEW EQUALITY (INT, EQUAL);
  73           FUNCTION "=" (LEFT, RIGHT : INT) RETURN BOOLEAN
  74                RENAMES INT_EQUALITY."=";
  75      END ABSTRACTION;
  76      USE ABSTRACTION;
  77
  78 BEGIN
  79
  80      TEST ("C67005C", "RENAMING OF EQUALITY OPERATOR WITH " &
  81            "NON-LIMITED PARAMETERS");
  82
  83      DECLARE
  84
  85           I : INT := VALUE_OF(1);
  86           J : INT := VALUE_OF(0);
  87
  88           PROCEDURE CHECK (B : BOOLEAN) IS
  89           BEGIN
  90                IF I = J AND B THEN
  91                     COMMENT ("I = J");
  92                ELSIF I /= J AND NOT B THEN
  93                     COMMENT ("I /= J");
  94                ELSE
  95                     FAILED ("WRONG ""="" OPERATOR");
  96                END IF;
  97           END CHECK;
  98
  99      BEGIN
 100
 101           CHECK(FALSE);
 102           I := VALUE_OF(0);
 103           CHECK(TRUE);
 104
 105           RESULT;
 106
 107      END;
 108
 109 END C67005C;