old-autovect-branch/gcc/testsuite/ada/acats/tests/ca/ca15003.a

   1 -- CA15003.A
   2 --                             Grant of Unlimited Rights
   3 --
   4 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   5 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   6 --     unlimited rights in the software and documentation contained herein.
   7 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   8 --     this public release, the Government intends to confer upon all
   9 --     recipients unlimited rights  equal to those held by the Government.
  10 --     These rights include rights to use, duplicate, release or disclose the
  11 --     released technical data and computer software in whole or in part, in
  12 --     any manner and for any purpose whatsoever, and to have or permit others
  13 --     to do so.
  14 --
  15 --                                    DISCLAIMER
  16 --
  17 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  18 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  19 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  20 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  21 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  22 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  23 --*
  24 --
  25 -- OBJECTIVE
  26 --     Check the requirements of 10.1.5(4) and the modified 10.1.5(5)
  27 --     from Technical Corrigendum 1. (Originally discussed as AI95-00136.)
  28 --     Specifically:
  29 --     Check that program unit pragma for a generic package are accepted
  30 --     when given at the beginning of the package specification.
  31 --     Check that a program unit pragma can be given for a generic
  32 --     instantiation by placing the pragma immediately after the instantation.
  33 --
  34 -- TEST DESCRIPTION
  35 --     This test checks the cases that are *not* forbidden by the RM,
  36 --     and makes sure such legal cases actually work.
  37 --
  38 -- CHANGE HISTORY:
  39 --      29 JUN 1999   RAD   Initial Version
  40 --      08 JUL 1999   RLB   Cleaned up and added to test suite.
  41 --      27 AUG 1999   RLB   Repaired errors introduced by me.
  42 --
  43 --!
  44
  45 with System;
  46 package CA15003A is
  47     pragma Pure;
  48
  49     type Big_Int is range -System.Max_Int .. System.Max_Int;
  50     type Big_Positive is new Big_Int range 1..Big_Int'Last;
  51 end CA15003A;
  52
  53 generic
  54     type Int is new Big_Int;
  55 package CA15003A.Pure is
  56     pragma Pure;
  57     function F(X: access Int) return Int;
  58 end CA15003A.Pure;
  59
  60 with CA15003A.Pure;
  61 package CA15003A.Pure_Instance is new CA15003A.Pure(Int => Big_Positive);
  62     pragma Pure(CA15003A.Pure_Instance);
  63
  64 package body CA15003A.Pure is
  65     function F(X: access Int) return Int is
  66     begin
  67         X.all := X.all + 1;
  68         return X.all;
  69     end F;
  70 end CA15003A.Pure;
  71
  72 generic
  73 package CA15003A.Pure.Preelaborate is
  74     pragma Preelaborate;
  75     One: Int := 1;
  76     function F(X: access Int) return Int;
  77 end CA15003A.Pure.Preelaborate;
  78
  79 package body CA15003A.Pure.Preelaborate is
  80     function F(X: access Int) return Int is
  81     begin
  82         X.all := X.all + One;
  83         return X.all;
  84     end F;
  85 end CA15003A.Pure.Preelaborate;
  86
  87 with CA15003A.Pure_Instance;
  88 with CA15003A.Pure.Preelaborate;
  89 package CA15003A.Pure_Preelaborate_Instance is
  90     new CA15003A.Pure_Instance.Preelaborate;
  91         pragma Preelaborate(CA15003A.Pure_Preelaborate_Instance);
  92
  93 package CA15003A.Empty_Pure is
  94     pragma Pure;
  95     pragma Elaborate_Body;
  96 end CA15003A.Empty_Pure;
  97
  98 package body CA15003A.Empty_Pure is
  99 end CA15003A.Empty_Pure;
 100
 101 package CA15003A.Empty_Preelaborate is
 102     pragma Preelaborate;
 103     pragma Elaborate_Body;
 104     One: Big_Int := 1;
 105 end CA15003A.Empty_Preelaborate;
 106
 107 package body CA15003A.Empty_Preelaborate is
 108     function F(X: access Big_Int) return Big_Int is
 109     begin
 110         X.all := X.all + One;
 111         return X.all;
 112     end F;
 113 end CA15003A.Empty_Preelaborate;
 114
 115 package CA15003A.Empty_Elaborate_Body is
 116     pragma Elaborate_Body;
 117     Three: aliased Big_Positive := 1;
 118     Two, Tres: Big_Positive'Base := 0;
 119 end CA15003A.Empty_Elaborate_Body;
 120
 121 with Report; use Report; pragma Elaborate_All(Report);
 122 with CA15003A.Pure_Instance;
 123 with CA15003A.Pure_Preelaborate_Instance;
 124 use CA15003A;
 125 package body CA15003A.Empty_Elaborate_Body is
 126 begin
 127     if Two /= Big_Positive'Base(Ident_Int(0)) then
 128         Failed ("Two should be zero now");
 129     end if;
 130     if Tres /= Big_Positive'Base(Ident_Int(0)) then
 131         Failed ("Tres should be zero now");
 132     end if;
 133     if Two /= Tres then
 134         Failed ("Tres should be zero now");
 135     end if;
 136     Two := Pure_Instance.F(Three'Access);
 137     Tres := Pure_Preelaborate_Instance.F(Three'Access);
 138     if Two /= Big_Positive(Ident_Int(2)) then
 139         Failed ("Two should be 2 now");
 140     end if;
 141     if Tres /= Big_Positive(Ident_Int(3)) then
 142         Failed ("Tres should be 3 now");
 143     end if;
 144 end CA15003A.Empty_Elaborate_Body;
 145
 146 with Report; use Report;
 147 with CA15003A.Empty_Pure;
 148 with CA15003A.Empty_Preelaborate;
 149 with CA15003A.Empty_Elaborate_Body; use CA15003A.Empty_Elaborate_Body;
 150 use type CA15003A.Big_Positive'Base;
 151 procedure CA15003 is
 152 begin
 153     Test("CA15003", "Placement of Program Unit Pragmas in Generic Packages");
 154     if Two /= 2 then
 155         Failed ("Two should be 2 now");
 156     end if;
 157     if Tres /= 3 then
 158         Failed ("Tres should be 3 now");
 159     end if;
 160     Result;
 161 end CA15003;