gomp-20050608-branch/gcc/testsuite/ada/acats/tests/cxh/cxh30031.am

   1 -- CXH30031.AM
   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 --
  26 -- OBJECTIVE
  27 --     Check pragma Reviewable.
  28 --     Check that pragma Reviewable is accepted as a configuration pragma.
  29 --
  30 -- TEST DESCRIPTION
  31 --     This test checks that pragma Reviewable is processed as a
  32 --     configuration pragma.  See CXH3001 for testing pragma Reviewable as
  33 --     other than a configuration pragma.
  34 --
  35 -- TEST FILES:
  36 --      The following files comprise this test:
  37 --
  38 --         CXH30030.A
  39 --      => CXH30031.AM
  40 --
  41 -- APPLICABILITY CRITERIA:
  42 --      This test is only applicable for a compiler attempting validation
  43 --      for the Safety and Security Annex.
  44 --
  45 -- SPECIAL REQUIREMENTS
  46 --      The implementation must process a configuration pragma which is not
  47 --      part of any Compilation Unit; the method employed is implementation
  48 --      defined.
  49 --
  50 --
  51 -- CHANGE HISTORY:
  52 --      26 OCT 95   SAIC   Initial version for 2.1
  53 --      07 JUN 96   SAIC   Revised by reviewer request
  54 --      03 NOV 96   SAIC   Documentation revision
  55 --
  56 --      03 NOV 96   Keith  Documentation revision
  57 --      27 AUG 99   RLB    Removed result dependence on uninitialized object.
  58 --      30 AUG 99   RLB    Repaired the above.
  59 --
  60 --!
  61
  62   pragma Reviewable;
  63
  64 ----------------------------------------------------------------- CXH3003_0
  65
  66 package CXH3003_0 is
  67
  68   type Enum is (Item,Stuff,Things);
  69
  70   type Int is range 0..256;
  71
  72   type Unt is mod 256;
  73
  74   type Flt is digits 5;
  75
  76   type Fix is delta 0.5 range -1.0..1.0;
  77
  78   type Root(Disc: Enum) is tagged record
  79     I: Int; U:Unt;
  80   end record;
  81
  82   type List is array(Unt) of Root(Stuff);
  83
  84   type A_List is access List;
  85   type A_Proc is access procedure(R:Root);
  86
  87   procedure P(R:Root);
  88
  89   function F return A_Proc;
  90
  91   Global_Variable : Boolean := False;
  92
  93 end CXH3003_0;
  94
  95 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
  96 with Report;
  97 package body CXH3003_0 is
  98
  99  procedure P(R:Root) is
 100     Warnable : Positive := 0;                             -- OPTIONAL WARNING
 101   begin
 102     case R.Disc is
 103       when Item   => Report.Comment("Got Item");
 104       when Stuff  => Report.Comment("Got Stuff");
 105       when Things => Report.Comment("Got Things");
 106     end case;
 107     if Report.Ident_Int( Warnable ) = 0 then
 108       Global_Variable := not Global_Variable;     -- known to be initialized
 109     end if;
 110   end P;
 111
 112   function F return A_Proc is
 113   begin
 114     return P'Access;
 115   end F;
 116
 117 end CXH3003_0;
 118
 119 ----------------------------------------------------------------- CXH3003_1
 120
 121 package CXH3003_0.CXH3003_1 is
 122
 123   protected PT is
 124     entry Set(Switch: Boolean);
 125     function Enquire return Boolean;
 126   private
 127     Toggle : Boolean;
 128   end PT;
 129
 130   task TT is
 131     entry Release;
 132   end TT;
 133
 134 end CXH3003_0.CXH3003_1;
 135
 136 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 137
 138 package body CXH3003_0.CXH3003_1 is
 139
 140   protected body PT is
 141
 142     entry Set(Switch: Boolean) when True is
 143     begin
 144       Toggle := Switch;
 145     end Set;
 146
 147     function Enquire return Boolean is
 148     begin
 149       return Toggle;
 150     end Enquire;
 151
 152   end PT;
 153
 154   task body TT is
 155   begin
 156     loop
 157       accept Release;
 158       exit when Global_Variable;
 159     end loop;
 160   end TT;
 161
 162  -- TT activation
 163
 164 end CXH3003_0.CXH3003_1;
 165
 166 ------------------------------------------------------------------- CXH3003
 167
 168 with Report;
 169 with CXH3003_0.CXH3003_1;
 170 procedure CXH30031 is
 171 begin
 172
 173   Report.Test("CXH3003", "Check pragma Reviewable as a configuration pragma");
 174
 175   Block: declare
 176     A_Truth : Boolean;
 177     Message : String := Report.Ident_Str( "Bad value encountered" );
 178   begin
 179     begin
 180       A_Truth := Report.Ident_Bool( True ) or A_Truth;  -- not initialized
 181       if not A_Truth then
 182         Report.Comment ("True or Uninit = False");
 183         A_Truth := Report.Ident_Bool (True);
 184       else
 185         A_Truth := Report.Ident_Bool (True);
 186           -- We do this separately on each branch in order to insure that a
 187           -- clever optimizer can find out little about this value. Ident_Bool
 188           -- is supposed to be opaque to any optimizer.
 189       end if;
 190     exception
 191       when Constraint_Error | Program_Error =>
 192            -- Possible results of accessing an uninitialized object.
 193         A_Truth := Report.Ident_Bool (True);
 194     end;
 195
 196     CXH3003_0.CXH3003_1.PT.Set( A_Truth );
 197
 198     CXH3003_0.Global_Variable := A_Truth;
 199
 200     CXH3003_0.CXH3003_1.TT.Release;  -- rendezvous with TT
 201
 202     while CXH3003_0.CXH3003_1.TT'Callable loop  -- wait for TT to complete
 203       delay 1.0;
 204     end loop;
 205
 206     if   not CXH3003_0.CXH3003_1.PT.Enquire
 207       or not CXH3003_0.Global_Variable then
 208       Report.Failed(Message);
 209     end if;
 210
 211   end Block;
 212
 213   Report.Result;
 214
 215 end CXH30031;