From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/testsuite/ada/acats/tests/cxh/cxh3002.a | 343 ++++++++++++++++++++++++++++ 1 file changed, 343 insertions(+) create mode 100644 gcc/testsuite/ada/acats/tests/cxh/cxh3002.a (limited to 'gcc/testsuite/ada/acats/tests/cxh/cxh3002.a') diff --git a/gcc/testsuite/ada/acats/tests/cxh/cxh3002.a b/gcc/testsuite/ada/acats/tests/cxh/cxh3002.a new file mode 100644 index 000000000..5e9f7b9cc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxh/cxh3002.a @@ -0,0 +1,343 @@ +-- 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; -- cgit v1.2.3