cxh3001.a

来自「linux下编程用 编译软件」· A 代码 · 共 244 行

-- CXH3001.A
--
--                             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
--     The test requires that the configuration pragma Reviewable
--     be processed.  The following package contains a simple "one of each
--     construct in the language" to check that the configuration pragma has
--     not disallowed some feature of the language.  This test should generate
--     no errors.
--
-- APPLICABILITY CRITERIA:
--      This test is only applicable for a compiler attempting validation
--      for the Safety and Security Annex.
--
-- PASS/FAIL CRITERIA:
--      This test passes if it correctly compiles, executes, and reports PASS.
--      It fails if the pragma is rejected.  The effect of the pragma should
--      be to produce a listing with information, including warnings, as
--      required in H.3.1. Specific form and contents of this listing are not
--      required by this test and are not part of the PASS/FAIL criteria.
--
-- SPECIAL REQUIREMENTS
--      The implementation must process a configuration pragma which is not
--      part of any Compilation Unit; the method employed is implementation
--      defined.
--
--      Pragma Reviewable requires that the implementation provide the
--      following information for the compilation units in this test:
--
--        o Where compiler-generated run-time checks remain (6)
--
--        o Identification of any construct with a language-defined check
--          that is recognized prior to runtime as certain to fail if
--          executed (7)
--
--        o For each reference to a scalar object, an identification of
--          the reference as either "known to be initialized,"
--          or "possibly uninitialized" (8)
--
--        o Where run-time support routines are implicitly invoked (9)
--
--        o An object code listing including: (10)
--
--          o Machine instructions with relative offsets (11)
--
--          o Where each data object is stored during its lifetime (12)
--
--          o Correspondence with the source program (13)
--
--        o Identification of each construct for which the implementation
--          detects the possibility of erroneous execution (14)
--
--        o For each subprogram, block, task or other construct implemented by
--          reserving and subsequently freezing an area of the run-time stack,
--          an identification of the length of the fixed-size portion of
--          the area and an indication of whether the non-fixed size portion
--          is reserved on the stack or in a dynamically managed storage
--          region (15)
--
--
-- CHANGE HISTORY:
--      26 OCT 95   SAIC   Initial version
--      12 NOV 96   SAIC   Revised for 2.1
--      27 AUG 99   RLB    Removed result dependence on uninitialized object.
--      30 AUG 99   RLB    Repaired the above.
--
--!

---------------------------- CONFIGURATION PRAGMAS -----------------------

pragma Reviewable;                                                -- OK
                                                -- configuration pragma

------------------------ END OF CONFIGURATION PRAGMAS --------------------


----------------------------------------------------------------- CXH3001_0

package CXH3001_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;

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

  task TT is
    entry Release;
  end TT;

  Global_Variable : Boolean := False;

end CXH3001_0;

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

with Report;
package body CXH3001_0 is

 procedure P(R:Root) is
    Warnable : Positive := 0; -- (7)                      -- OPTIONAL WARNING
    -- this would raise Constraint_Error if P were ever called, however
    -- this test never calls P.
  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; -- (8) known to be initialized
    end if;
  end P;

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

  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;

  -- (9) TT activation
end CXH3001_0;

------------------------------------------------------------------- CXH3001

with Report;
with CXH3001_0;
procedure CXH3001 is
begin
  Report.Test("CXH3001", "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;  -- (8) 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;

    CXH3001_0.PT.Set( A_Truth );

    CXH3001_0.Global_Variable := A_Truth;

    CXH3001_0.TT.Release;  -- (9) rendezvous with TT

    while CXH3001_0.TT'Callable loop
      delay 1.0; -- wait for TT to become non-callable
    end loop;

    if   not CXH3001_0.PT.Enquire
      or not CXH3001_0.Global_Variable
      or CXH3001_0.TT'Callable then
      Report.Failed(Message);
    end if;

  end Block;

  Report.Result;
end CXH3001;