gcc/testsuite/ada/acats/tests/cxh/cxh3001.a

   1 -- CXH3001.A
   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 --     The test requires that the configuration pragma Reviewable
  32 --     be processed.  The following package contains a simple "one of each
  33 --     construct in the language" to check that the configuration pragma has
  34 --     not disallowed some feature of the language.  This test should generate
  35 --     no errors.
  36 --
  37 -- APPLICABILITY CRITERIA:
  38 --      This test is only applicable for a compiler attempting validation
  39 --      for the Safety and Security Annex.
  40 --
  41 -- PASS/FAIL CRITERIA:
  42 --      This test passes if it correctly compiles, executes, and reports PASS.
  43 --      It fails if the pragma is rejected.  The effect of the pragma should
  44 --      be to produce a listing with information, including warnings, as
  45 --      required in H.3.1. Specific form and contents of this listing are not
  46 --      required by this test and are not part of the PASS/FAIL criteria.
  47 --
  48 -- SPECIAL REQUIREMENTS
  49 --      The implementation must process a configuration pragma which is not
  50 --      part of any Compilation Unit; the method employed is implementation
  51 --      defined.
  52 --
  53 --      Pragma Reviewable requires that the implementation provide the
  54 --      following information for the compilation units in this test:
  55 --
  56 --        o Where compiler-generated run-time checks remain (6)
  57 --
  58 --        o Identification of any construct with a language-defined check
  59 --          that is recognized prior to runtime as certain to fail if
  60 --          executed (7)
  61 --
  62 --        o For each reference to a scalar object, an identification of
  63 --          the reference as either "known to be initialized,"
  64 --          or "possibly uninitialized" (8)
  65 --
  66 --        o Where run-time support routines are implicitly invoked (9)
  67 --
  68 --        o An object code listing including: (10)
  69 --
  70 --          o Machine instructions with relative offsets (11)
  71 --
  72 --          o Where each data object is stored during its lifetime (12)
  73 --
  74 --          o Correspondence with the source program (13)
  75 --
  76 --        o Identification of each construct for which the implementation
  77 --          detects the possibility of erroneous execution (14)
  78 --
  79 --        o For each subprogram, block, task or other construct implemented by
  80 --          reserving and subsequently freezing an area of the run-time stack,
  81 --          an identification of the length of the fixed-size portion of
  82 --          the area and an indication of whether the non-fixed size portion
  83 --          is reserved on the stack or in a dynamically managed storage
  84 --          region (15)
  85 --
  86 --
  87 -- CHANGE HISTORY:
  88 --      26 OCT 95   SAIC   Initial version
  89 --      12 NOV 96   SAIC   Revised for 2.1
  90 --      27 AUG 99   RLB    Removed result dependence on uninitialized object.
  91 --      30 AUG 99   RLB    Repaired the above.
  92 --
  93 --!
  94
  95 ---------------------------- CONFIGURATION PRAGMAS -----------------------
  96
  97 pragma Reviewable;                                                -- OK
  98                                                 -- configuration pragma
  99
 100 ------------------------ END OF CONFIGURATION PRAGMAS --------------------
 101
 102
 103 ----------------------------------------------------------------- CXH3001_0
 104
 105 package CXH3001_0 is
 106
 107   type Enum is (Item,Stuff,Things);
 108
 109   type Int is range 0..256;
 110
 111   type Unt is mod 256;
 112
 113   type Flt is digits 5;
 114
 115   type Fix is delta 0.5 range -1.0..1.0;
 116
 117   type Root(Disc: Enum) is tagged record
 118     I: Int; U:Unt;
 119   end record;
 120
 121   type List is array(Unt) of Root(Stuff);
 122
 123   type A_List is access List;
 124   type A_Proc is access procedure(R:Root);
 125
 126   procedure P(R:Root);
 127
 128   function F return A_Proc;
 129
 130   protected PT is
 131     entry Set(Switch: Boolean);
 132     function Enquire return Boolean;
 133   private
 134     Toggle : Boolean;
 135   end PT;
 136
 137   task TT is
 138     entry Release;
 139   end TT;
 140
 141   Global_Variable : Boolean := False;
 142
 143 end CXH3001_0;
 144
 145 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 146
 147 with Report;
 148 package body CXH3001_0 is
 149
 150  procedure P(R:Root) is
 151     Warnable : Positive := 0; -- (7)                      -- OPTIONAL WARNING
 152     -- this would raise Constraint_Error if P were ever called, however
 153     -- this test never calls P.
 154   begin
 155     case R.Disc is
 156       when Item   => Report.Comment("Got Item");
 157       when Stuff  => Report.Comment("Got Stuff");
 158       when Things => Report.Comment("Got Things");
 159     end case;
 160     if Report.Ident_Int( Warnable ) = 0 then
 161       Global_Variable := not Global_Variable; -- (8) known to be initialized
 162     end if;
 163   end P;
 164
 165   function F return A_Proc is
 166   begin
 167     return P'Access;
 168   end F;
 169
 170   protected body PT is
 171
 172     entry Set(Switch: Boolean) when True is
 173     begin
 174       Toggle := Switch;
 175     end Set;
 176
 177     function Enquire return Boolean is
 178     begin
 179       return Toggle;
 180     end Enquire;
 181
 182   end PT;
 183
 184   task body TT is
 185   begin
 186     loop
 187       accept Release;
 188       exit when Global_Variable;
 189     end loop;
 190   end TT;
 191
 192   -- (9) TT activation
 193 end CXH3001_0;
 194
 195 ------------------------------------------------------------------- CXH3001
 196
 197 with Report;
 198 with CXH3001_0;
 199 procedure CXH3001 is
 200 begin
 201   Report.Test("CXH3001", "Check pragma Reviewable as a configuration pragma");
 202
 203   Block: declare
 204     A_Truth : Boolean;
 205     Message : String := Report.Ident_Str( "Bad value encountered" );
 206   begin
 207     begin
 208       A_Truth := Report.Ident_Bool( True ) or A_Truth;  -- (8) not initialized
 209       if not A_Truth then
 210         Report.Comment ("True or Uninit = False");
 211         A_Truth := Report.Ident_Bool (True);
 212       else
 213         A_Truth := Report.Ident_Bool (True);
 214           -- We do this separately on each branch in order to insure that a
 215           -- clever optimizer can find out little about this value. Ident_Bool
 216           -- is supposed to be opaque to any optimizer.
 217       end if;
 218     exception
 219       when Constraint_Error | Program_Error =>
 220            -- Possible results of accessing an uninitialized object.
 221         A_Truth := Report.Ident_Bool (True);
 222     end;
 223
 224     CXH3001_0.PT.Set( A_Truth );
 225
 226     CXH3001_0.Global_Variable := A_Truth;
 227
 228     CXH3001_0.TT.Release;  -- (9) rendezvous with TT
 229
 230     while CXH3001_0.TT'Callable loop
 231       delay 1.0; -- wait for TT to become non-callable
 232     end loop;
 233
 234     if   not CXH3001_0.PT.Enquire
 235       or not CXH3001_0.Global_Variable
 236       or CXH3001_0.TT'Callable then
 237       Report.Failed(Message);
 238     end if;
 239
 240   end Block;
 241
 242   Report.Result;
 243 end CXH3001;