llvm-gcc-4.0/gcc/testsuite/ada/acats/tests/cxh/cxh30031.am

-- CXH30031.AM
--
--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
--     this public release, the Government intends to confer upon all
--     recipients unlimited rights  equal to those held by the Government.
--     These rights include rights to use, duplicate, release or disclose the
--     released technical data and computer software in whole or in part, in
--     any manner and for any purpose whatsoever, and to have or permit others
--     to do so.
--
--                                    DISCLAIMER
--
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--     PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE
--     Check pragma Reviewable.
--     Check that pragma Reviewable is accepted as a configuration pragma.
--
-- TEST DESCRIPTION
--     This test checks that pragma Reviewable is processed as a
--     configuration pragma.  See CXH3001 for testing pragma Reviewable as
--     other than a configuration pragma.
--
-- TEST FILES:
--      The following files comprise this test:
--
--         CXH30030.A
--      => CXH30031.AM
--
-- APPLICABILITY CRITERIA:
--      This test is only applicable for a compiler attempting validation
--      for the Safety and Security Annex.
--
-- SPECIAL REQUIREMENTS
--      The implementation must process a configuration pragma which is not
--      part of any Compilation Unit; the method employed is implementation
--      defined.
--
--
-- CHANGE HISTORY:
--      26 OCT 95   SAIC   Initial version for 2.1
--      07 JUN 96   SAIC   Revised by reviewer request
--      03 NOV 96   SAIC   Documentation revision
--
--      03 NOV 96   Keith  Documentation revision
--      27 AUG 99   RLB    Removed result dependence on uninitialized object.
--      30 AUG 99   RLB    Repaired the above.
--
--!

  pragma Reviewable;

----------------------------------------------------------------- CXH3003_0

package CXH3003_0 is

  type Enum is (Item,Stuff,Things);

  type Int is range 0..256;

  type Unt is mod 256;

  type Flt is digits 5;

  type Fix is delta 0.5 range -1.0..1.0;

  type Root(Disc: Enum) is tagged record
    I: Int; U:Unt;
  end record;

  type List is array(Unt) of Root(Stuff);

  type A_List is access List;
  type A_Proc is access procedure(R:Root);

  procedure P(R:Root);

  function F return A_Proc;

  Global_Variable : Boolean := False;

end CXH3003_0;

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
with Report;
package body CXH3003_0 is

 procedure P(R:Root) is
    Warnable : Positive := 0;                             -- OPTIONAL WARNING
  begin
    case R.Disc is
      when Item   => Report.Comment("Got Item");
      when Stuff  => Report.Comment("Got Stuff");
      when Things => Report.Comment("Got Things");
    end case;
    if Report.Ident_Int( Warnable ) = 0 then
      Global_Variable := not Global_Variable;     -- known to be initialized
    end if;
  end P;

  function F return A_Proc is
  begin
    return P'Access;
  end F;

end CXH3003_0;

----------------------------------------------------------------- CXH3003_1

package CXH3003_0.CXH3003_1 is

  protected PT is
    entry Set(Switch: Boolean);
    function Enquire return Boolean;
  private
    Toggle : Boolean;
  end PT;

  task TT is
    entry Release;
  end TT;

end CXH3003_0.CXH3003_1;

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

package body CXH3003_0.CXH3003_1 is

  protected body PT is

    entry Set(Switch: Boolean) when True is
    begin
      Toggle := Switch;
    end Set;

    function Enquire return Boolean is
    begin
      return Toggle;
    end Enquire;

  end PT;

  task body TT is
  begin
    loop
      accept Release;
      exit when Global_Variable;
    end loop;
  end TT;

 -- TT activation

end CXH3003_0.CXH3003_1;

------------------------------------------------------------------- CXH3003

with Report;
with CXH3003_0.CXH3003_1;
procedure CXH30031 is
begin

  Report.Test("CXH3003", "Check pragma Reviewable as a configuration pragma");

  Block: declare
    A_Truth : Boolean;
    Message : String := Report.Ident_Str( "Bad value encountered" );
  begin
    begin
      A_Truth := Report.Ident_Bool( True ) or A_Truth;  -- not initialized
      if not A_Truth then
        Report.Comment ("True or Uninit = False");
        A_Truth := Report.Ident_Bool (True);
      else
        A_Truth := Report.Ident_Bool (True);
          -- We do this separately on each branch in order to insure that a
          -- clever optimizer can find out little about this value. Ident_Bool
          -- is supposed to be opaque to any optimizer.
      end if;
    exception
      when Constraint_Error | Program_Error =>
           -- Possible results of accessing an uninitialized object.
        A_Truth := Report.Ident_Bool (True);
    end;

    CXH3003_0.CXH3003_1.PT.Set( A_Truth );

    CXH3003_0.Global_Variable := A_Truth;

    CXH3003_0.CXH3003_1.TT.Release;  -- rendezvous with TT

    while CXH3003_0.CXH3003_1.TT'Callable loop  -- wait for TT to complete
      delay 1.0;
    end loop;

    if   not CXH3003_0.CXH3003_1.PT.Enquire
      or not CXH3003_0.Global_Variable then
      Report.Failed(Message);
    end if;

  end Block;

  Report.Result;

end CXH30031;