Subversion Repositories openrisc_me

-- CXH3002.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 that pragma Inspection_Point is allowed whereever a declarative

--     item or statement is allowed.  Check that pragma Inspection_Point may

--     have zero or more arguments.  Check that the execution of pragma

--     Inspection_Point has no effect.

--

-- TEST DESCRIPTION

--     Check pragma Inspection_Point applied to:

--       A no objects,

--       B one object,

--       C multiple objects.

--     Check pragma Inspection_Point applied to:

--       D Enumeration type objects,

--       E Integer type objects (signed and unsigned),

--       F access type objects,

--       G Floating Point type objects,

--       H Fixed point type objects,

--       I array type objects,

--       J record type objects,

--       K tagged type objects,

--       L protected type objects,

--       M controlled type objects,

--       N task type objects.

--     Check pragma Inspection_Point applied in:

--       O declarations (package, procedure)

--       P statements (incl package elaboration)

--       Q subprogram (procedure, function, finalization)

--       R package

--       S specification

--       T body (PO entry, task body, loop body, accept body, select body)

--       U task

--       V protected object

--

--

-- 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

--      12 NOV 96   SAIC   Revised for 2.1

--

--!

----------------------------------------------------------------- CXH3002_0

package CXH3002_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 record

    I: Int;

    U: Unt;

  end record;

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

  type A_List is access all List;

  type A_Proc is access procedure(R:Root);

  procedure Proc(R:Root);

  function  Func return A_Proc;

  protected type PT is

    entry Prot_Entry(Switch: Boolean);

  private

    Toggle : Boolean := False;

  end PT;

  task type TT is

    entry Task_Entry(Items: in A_List);

  end TT;

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====

  pragma Inspection_Point;                                          -- AORS

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====

end CXH3002_0;

----------------------------------------------------------------- CXH3002_1

with Ada.Finalization;

package CXH3002_0.CXH3002_1 is

  type Final is new Ada.Finalization.Controlled with

    record

      Value : Natural;

    end record;

  procedure Initialize( F: in out Final );

  procedure Adjust( F: in out Final );

  procedure Finalize( F: in out Final );

end CXH3002_0.CXH3002_1;

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- CXH3002_0

package body CXH3002_0 is

  Global_Variable : Character := 'A';

  procedure Proc(R:Root) is

  begin

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====

    pragma Inspection_Point( Global_Variable );                     -- BDPQT

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====

    case R.Disc is

      when Item   => Global_Variable := 'I';

      when Stuff  => Global_Variable := 'S';

      when Things => Global_Variable := 'T';

    end case;

 end Proc;

  function Func return A_Proc is

  begin

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====

    pragma Inspection_Point;                                        -- APQT

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====

    return Proc'Access;

  end Func;

  protected body PT is

    entry Prot_Entry(Switch: Boolean) when True is

      begin

        Toggle := Switch;

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====

        pragma Inspection_Point;                                    -- APVT

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====

      end Prot_Entry;

  end PT;

  task body TT is

    List_Copy : A_List;

  begin

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====

    pragma Inspection_Point;                                        -- APUT

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====

    loop

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====

      pragma Inspection_Point;                                      -- APUT

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====

      select

        accept Task_Entry(Items: in A_List) do

          List_Copy := Items;

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====

          pragma Inspection_Point( List_Copy );                     -- BFPUT

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====

        end Task_Entry;

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====

        pragma Inspection_Point;                                    -- APUT

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====

      or terminate;

      end select;

    end loop;

  end TT;

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====

  pragma Inspection_Point;                                           -- ARTO

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====

end CXH3002_0;

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- CXH3002_1

with Report;

package body CXH3002_0.CXH3002_1 is

  Embedded_Final_Object : Final

                        := (Ada.Finalization.Controlled with Value => 1);

                        -- attempt to call Initialize here would P_E!

  procedure Initialize( F: in out Final ) is

  begin

    F.Value := 1;

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====

    pragma Inspection_Point( Embedded_Final_Object );                -- BKQP

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====

  end Initialize;

  procedure Adjust( F: in out Final ) is

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====

    pragma Inspection_Point;                                          -- AQO

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====

  begin

    F.Value := 2;

  end Adjust;

  procedure Finalize( F: in out Final ) is

  begin

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====

    pragma Inspection_Point;                                         -- AQP

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====

    if F.Value not in 1..10 then

      Report.Failed("Bad value in controlled object at finalization");

    end if;

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====

    pragma Inspection_Point;                                         -- AQP

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====

  end Finalize;

begin

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---======

  pragma Inspection_Point( Embedded_Final_Object );                  -- BKRTP

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---======

  null;

end CXH3002_0.CXH3002_1;

------------------------------------------------------------------- CXH3002

with Report;

with CXH3002_0.CXH3002_1;

procedure CXH3002 is

  use type CXH3002_0.Enum, CXH3002_0.Int, CXH3002_0.Unt, CXH3002_0.Flt,

           CXH3002_0.Fix,  CXH3002_0.Root;

  Main_Enum  : CXH3002_0.Enum := CXH3002_0.Item;

  Main_Int   : CXH3002_0.Int;

  Main_Unt   : CXH3002_0.Unt;

  Main_Flt   : CXH3002_0.Flt;

  Main_Fix   : CXH3002_0.Fix;

  Main_Rec   : CXH3002_0.Root(CXH3002_0.Stuff)

               := (CXH3002_0.Stuff, I => 1, U => 2);

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====

  pragma Inspection_Point( Main_Rec );                               -- BJQO

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---=====

  Main_List   : CXH3002_0.List := ( others => Main_Rec );

  Main_A_List : CXH3002_0.A_List := new CXH3002_0.List'( others => Main_Rec );

  Main_A_Proc : CXH3002_0.A_Proc := CXH3002_0.Func;

                                 -- CXH3002_0.Proc'Access

  Main_PT     : CXH3002_0.PT;

  Main_TT     : CXH3002_0.TT;

  type Test_Range is (First, Second);

  procedure Assert( Truth : Boolean; Message : String ) is

  begin

    if not Truth then

      Report.Failed( "Unexpected value found in " & Message );

    end if;

  end Assert;

begin  -- Main test procedure.

  Report.Test ("CXH3002", "Check pragma Inspection_Point" );

 Enclosure:declare

   Main_Final : CXH3002_0.CXH3002_1.Final;

   Xtra_Final : CXH3002_0.CXH3002_1.Final;

 begin

  for Test_Case in Test_Range loop

    case Test_Case is

      when First  =>

        Main_Final.Value := 5;

        Xtra_Final := Main_Final; -- call Adjust

        Main_Enum  := CXH3002_0.Things;

        Main_Int   := CXH3002_0.Int'First;

        Main_Unt   := CXH3002_0.Unt'Last;

        Main_Flt   := 3.14;

        Main_Fix   := 0.5;

        Main_Rec   := (CXH3002_0.Stuff, I => 3, U => 4);

        Main_List(Main_Unt) := Main_Rec;

        Main_A_List(CXH3002_0.Unt'First) := (CXH3002_0.Stuff, I => 5, U => 6);

        Main_A_Proc( Main_A_List(2) );

        Main_PT.Prot_Entry(True);

        Main_TT.Task_Entry( null );

      when Second =>

        Assert( Main_Final.Value = 5, "Main_Final" );

        Assert( Xtra_Final.Value = 2, "Xtra_Final" );

        Assert( Main_Enum = CXH3002_0.Things, "Main_Enum" );

        Assert( Main_Int = CXH3002_0.Int'First, "Main_Int" );

        Assert( Main_Unt = CXH3002_0.Unt'Last, "Main_Unt" );

        Assert( Main_Flt in 3.0..3.5, "Main_Flt" );

        Assert( Main_Fix = 0.5, "Main_Fix" );

        Assert( Main_Rec = (CXH3002_0.Stuff, I => 3, U => 4), "Main_Rec" );

        Assert( Main_List(Main_Unt) = Main_Rec, "Main_List" );

        Assert( Main_A_List(CXH3002_0.Unt'First)

                  = (CXH3002_0.Stuff, I => 5, U => 6), "Main_A_List" );

   end case;

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==

    pragma Inspection_Point(                                       -- CQP

                      Main_Final,                                    -- M

                      Main_Enum,                                     -- D

                      Main_Int,                                      -- E

                      Main_Unt,                                      -- E

                      Main_Flt,                                      -- G

                      Main_Fix,                                      -- H

                      Main_Rec,                                      -- J

                      Main_List,                                     -- I

                      Main_A_List,                                   -- F

                      Main_A_Proc,                                   -- F

                      Main_PT,                                       -- L

                      Main_TT );                                     -- N

  -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==

  end loop;

 end Enclosure;

  Report.Result;

end CXH3002;