-- CXH3002.A -- -- Grant of Unlimited Rights -- -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and -- F08630-91-C-0015, 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;