cxh1001.a

来自「用于进行gcc测试」· A 代码 · 共 350 行

-- CXH1001.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 Normalize_Scalars.
--     Check that this configuration pragma causes uninitialized scalar
--     objects to be set to a predictable value.  Check that multiple
--     compilation units are affected.  Check for uninitialized scalar
--     objects that are subcomponents of composite objects, unassigned
--     out parameters, objects that have been allocated without an initial
--     value, and objects that are stand alone.
--
-- TEST DESCRIPTION
--     The test requires that the configuration pragma Normalize_Scalars
--     be processed.  It then defines a few scalar types (some enumeration,
--     some integer) in a few packages.  The scalar types are designed such
--     that the representation will easily allow for an out of range value.
--     Unchecked_Conversion and the 'Valid attribute are both used to verify
--     that the default values of the various kinds of objects are indeed
--     invalid for the type.
--
--     Note that this test relies on having uninitialized objects, compilers
--     may generate several warnings to this effect.
--
-- SPECIAL REQUIREMENTS
--      The implementation must process configuration pragmas which
--      are not part of any Compilation Unit;  the method employed
--      is implementation defined.
--
-- APPLICABILITY CRITERIA:
--      This test is only applicable for a compiler attempting validation
--      for the Safety and Security Annex.
--
--
-- CHANGE HISTORY:
--      26 OCT 95   SAIC   Initial version
--      04 NOV 96   SAIC   Added cases, upgraded commentary
--
--!

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

pragma Normalize_Scalars;                                         -- OK
                                                -- configuration pragma

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


----------------------------------------------------------------- CXH1001_0

with Impdef.Annex_H;
with Unchecked_Conversion;
package CXH1001_0 is

  package Imp_H renames Impdef.Annex_H;
  use type Imp_H.Small_Number;
  use type Imp_H.Scalar_To_Normalize;

  Global_Object : Imp_H.Scalar_To_Normalize;
  -- if the pragma is in effect, this should come up with the predictable
  -- value

  Global_Number : Imp_H.Small_Number;
  -- if the pragma is in effect, this should come up with the predictable
  -- value

  procedure Package_Check;

  type Num is range 0..2**Imp_H.Scalar_To_Normalize'Size-1;
  for Num'Size use Imp_H.Scalar_To_Normalize'Size;  

  function STN_2_Num is
     new Unchecked_Conversion( Imp_H.Scalar_To_Normalize, Num );

  Small_Last : constant Integer := Integer(Imp_H.Small_Number'Last);

end CXH1001_0;

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

with Report;
package body CXH1001_0 is

  procedure Heap_Check( A_Value  : access Imp_H.Scalar_To_Normalize;
                        A_Number : access Imp_H.Small_Number ) is
    Value  : Num;
    Number : Integer;
  begin

    if A_Value.all'Valid then
      Value := STN_2_Num ( A_Value.all );
      if Imp_H.Default_For_Scalar_To_Normalize_Is_In_Range then
        if Imp_H.Scalar_To_Normalize'Val(Value)
           /= Imp_H.Default_For_Scalar_To_Normalize then
          Report.Failed("Implicit initial value for local variable is not "
                         & "the predicted value"); 
        end if;
      else
        if Value in 0 ..
            Imp_H.Scalar_To_Normalize'Pos(Imp_H.Scalar_To_Normalize'Last) then
          Report.Failed("Implicit initial value for local variable is a "
                         & "value of the type"); 
        end if;
      end if;
    end if;

    if A_Number.all'Valid then
      Number := Integer( A_Number.all );
      if Imp_H.Default_For_Small_Number_Is_In_Range then
        if Global_Number /= Imp_H.Default_For_Small_Number then
          Report.Failed("Implicit initial value for number is not "
                         & "the predicted value"); 
        end if;
      else
        if Integer( Global_Number ) in 0 .. Report.Ident_Int(Small_Last) then
          Report.Failed("Implicit initial value for number is a "
                         & "value of the type"); 
        end if;
      end if;
    end if;

  end Heap_Check;

  procedure Package_Check is
    Value  : Num;
    Number : Integer;
  begin

    if Global_Object'Valid then
      Value := STN_2_Num ( Global_Object );
      if Imp_H.Default_For_Scalar_To_Normalize_Is_In_Range then
        if Imp_H.Scalar_To_Normalize'Val(Value)
           /= Imp_H.Default_For_Scalar_To_Normalize then
          Report.Failed("Implicit initial value for local variable is not "
                         & "the predicted value"); 
        end if;
      else
        if Value in 0 .. 
            Imp_H.Scalar_To_Normalize'Pos(Imp_H.Scalar_To_Normalize'Last) then
          Report.Failed("Implicit initial value for local variable is a "
                         & "value of the type"); 
        end if;
      end if;
    end if;

    if Global_Number'Valid then
      Number := Integer( Global_Number );
      if Imp_H.Default_For_Small_Number_Is_In_Range then
        if Global_Number /= Imp_H.Default_For_Small_Number then
          Report.Failed("Implicit initial value for number is not "
                         & "the predicted value"); 
        end if;
      else
        if Integer( Global_Number ) in 0 .. Report.Ident_Int(Small_Last) then
          Report.Failed("Implicit initial value for number is a "
                         & "value of the type"); 
        end if;
      end if;
    end if;

    Heap_Check( new Imp_H.Scalar_To_Normalize, new Imp_H.Small_Number );

  end Package_Check;

end CXH1001_0;

----------------------------------------------------------------- CXH1001_1

with Unchecked_Conversion;
package CXH1001_0.CXH1001_1 is

  -- kill as many birds as possible with a single stone:
  --   embed a protected object in the body of a child package,
  -- checks the multiple compilation unit case,
  -- and part of the subcomponent case.

  protected Thingy is
    procedure Check_Embedded_Values;
  private
    Hidden_Object : Imp_H.Scalar_To_Normalize;  -- not initialized
    Hidden_Number : Imp_H.Small_Number;         -- not initialized
  end Thingy;

end CXH1001_0.CXH1001_1;

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

with Report;
package body CXH1001_0.CXH1001_1 is

  Childs_Object : Imp_H.Scalar_To_Normalize;  -- not initialized

  protected body Thingy is

    procedure Check_Embedded_Values is
    begin

      if Imp_H.Default_For_Scalar_To_Normalize_Is_In_Range then
        if Childs_Object /= Imp_H.Default_For_Scalar_To_Normalize then
          Report.Failed("Implicit initial value for child object is not "
                         & "the predicted value"); 
        end if;
      elsif Childs_Object'Valid and then STN_2_Num( Childs_Object ) in 0 ..
            Imp_H.Scalar_To_Normalize'Pos(Imp_H.Scalar_To_Normalize'Last) then
          Report.Failed("Implicit initial value for child object is a "
                         & "value of the type"); 
      end if;

      if Imp_H.Default_For_Scalar_To_Normalize_Is_In_Range then
        if Hidden_Object /= Imp_H.Default_For_Scalar_To_Normalize then
          Report.Failed("Implicit initial value for protected package object "
                         & "is not the predicted value"); 
        end if;
      elsif Hidden_Object'Valid and then STN_2_Num( Hidden_Object ) in 0 ..
            Imp_H.Scalar_To_Normalize'Pos(Imp_H.Scalar_To_Normalize'Last) then
          Report.Failed("Implicit initial value for protected component "
                         & "is a value of the type"); 
      end if;

      if Imp_H.Default_For_Small_Number_Is_In_Range then
        if Hidden_Number /= Imp_H.Default_For_Small_Number then
          Report.Failed("Implicit initial value for protected number "
                         & "is not the predicted value"); 
        end if;
      elsif Hidden_Number'Valid and then Hidden_Number in
                    0 .. Imp_H.Small_Number(Report.Ident_Int(Small_Last)) then
          Report.Failed("Implicit initial value for protected number "
                         & "is a value of the type"); 
      end if;

    end Check_Embedded_Values;

 end Thingy;

end CXH1001_0.CXH1001_1;

------------------------------------------------------------------- CXH1001

with Impdef.Annex_H;
with Report;
with CXH1001_0.CXH1001_1;
procedure CXH1001 is

  package Imp_H renames Impdef.Annex_H;
  use type CXH1001_0.Num;

  My_Object : Imp_H.Scalar_To_Normalize;  -- not initialized

  Value     : CXH1001_0.Num := CXH1001_0.STN_2_Num ( My_Object );
                               -- My_Object is not initialized

  Parameter_Value : Imp_H.Scalar_To_Normalize
                  := Imp_H.Scalar_To_Normalize'Last;

  type Structure is record  -- not initialized
    Std_Int : Integer;
    Scalar  : Imp_H.Scalar_To_Normalize;
    Num     : CXH1001_0.Num;
  end record;

  S : Structure;  -- not initialized

  procedure Bad_Code( Unassigned : out Imp_H.Scalar_To_Normalize ) is
    -- returns uninitialized OUT parameter
  begin

    if Report.Ident_Int( 0 ) = 1 then
      Report.Failed( "Nothing is something" );
      Unassigned := Imp_H.Scalar_To_Normalize'First;
    end if;

  end Bad_Code; 

  procedure Check( V : CXH1001_0.Num; Message : String ) is
  begin


    if Imp_H.Default_For_Scalar_To_Normalize_Is_In_Range then
      if V /= Imp_H.Scalar_To_Normalize'Pos(
                                  Imp_H.Default_For_Scalar_To_Normalize) then
        Report.Failed(Message & ": Implicit initial value for object "
                       & "is not the predicted value"); 
      end if;
    elsif V'Valid and then V in
      0 .. Imp_H.Scalar_To_Normalize'Pos(Imp_H.Scalar_To_Normalize'Last) then
      Report.Failed(Message & ": Implicit initial value for object "
                     & "is a value of the type"); 
    end if;

  end Check;

begin  -- Main test procedure.

  Report.Test ("CXH1001", "Check that the configuration pragma " &
                          "Normalize_Scalars causes uninitialized scalar " &
                          "objects to be set to a predictable value. " &
                          "Check that multiple compilation units are " &
                          "affected.  Check for uninitialized scalar " &
                          "objects that are subcomponents of composite " &
                          "objects, unassigned out parameters, have been " &
                          "allocated without an initial value, and are " &
                          "stand alone." );
   
  CXH1001_0.Package_Check;

  if My_Object'Valid then
    Value := CXH1001_0.STN_2_Num ( My_Object ); -- My_Object not initialized
  end if;
  -- otherwise, we just leave Value uninitialized

  Check( Value, "main procedure variable" );

  Bad_Code( Parameter_Value );

  if Parameter_Value'Valid then
    Check( CXH1001_0.STN_2_Num ( Parameter_Value ), "Out parameter return" );
  end if;

  if S.Scalar'Valid then
    Check( CXH1001_0.STN_2_Num ( S.Scalar ), "Record component" );
  end if;

  CXH1001_0.CXH1001_1.Thingy.Check_Embedded_Values;

  Report.Result;

end CXH1001;