diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/cxh')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cxh/cxh1001.a | 349 | ||||
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cxh/cxh3001.a | 243 | ||||
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cxh/cxh3002.a | 343 | ||||
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cxh/cxh30030.a | 54 | ||||
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cxh/cxh30031.am | 215 |
5 files changed, 1204 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/cxh/cxh1001.a b/gcc/testsuite/ada/acats/tests/cxh/cxh1001.a new file mode 100644 index 000000000..12379a1a5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxh/cxh1001.a @@ -0,0 +1,349 @@ +-- 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; diff --git a/gcc/testsuite/ada/acats/tests/cxh/cxh3001.a b/gcc/testsuite/ada/acats/tests/cxh/cxh3001.a new file mode 100644 index 000000000..4ed41b4d0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxh/cxh3001.a @@ -0,0 +1,243 @@ +-- 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; 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; diff --git a/gcc/testsuite/ada/acats/tests/cxh/cxh30030.a b/gcc/testsuite/ada/acats/tests/cxh/cxh30030.a new file mode 100644 index 000000000..1b1399c59 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxh/cxh30030.a @@ -0,0 +1,54 @@ +-- CXH30030.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 +-- See CHX30031.AM +-- +-- TEST DESCRIPTION +-- See CHX30031.AM +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- => CXH30030.A +-- CXH30031.AM +-- +-- APPLICABILITY CRITERIA: +-- See CHX30031.AM +-- +-- SPECIAL REQUIREMENTS +-- See CHX30031.AM +-- +-- CHANGE HISTORY: +-- 26 OCT 95 SAIC Initial version for 2.1 +-- 07 JUN 96 SAIC Revised by reviewer request, split to multifile +-- +--! + + pragma Reviewable; + +-- This test requires that this configuration pragma be applied to all +-- following compilation units in the environment; specifically the ones +-- in file CXH30031.AM diff --git a/gcc/testsuite/ada/acats/tests/cxh/cxh30031.am b/gcc/testsuite/ada/acats/tests/cxh/cxh30031.am new file mode 100644 index 000000000..91bf3e8a5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxh/cxh30031.am @@ -0,0 +1,215 @@ +-- CXH30031.AM +-- +-- 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 +-- This test checks that pragma Reviewable is processed as a +-- configuration pragma. See CXH3001 for testing pragma Reviewable as +-- other than a configuration pragma. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- CXH30030.A +-- => CXH30031.AM +-- +-- APPLICABILITY CRITERIA: +-- This test is only applicable for a compiler attempting validation +-- for the Safety and Security Annex. +-- +-- SPECIAL REQUIREMENTS +-- The implementation must process a configuration pragma which is not +-- part of any Compilation Unit; the method employed is implementation +-- defined. +-- +-- +-- CHANGE HISTORY: +-- 26 OCT 95 SAIC Initial version for 2.1 +-- 07 JUN 96 SAIC Revised by reviewer request +-- 03 NOV 96 SAIC Documentation revision +-- +-- 03 NOV 96 Keith Documentation revision +-- 27 AUG 99 RLB Removed result dependence on uninitialized object. +-- 30 AUG 99 RLB Repaired the above. +-- +--! + + pragma Reviewable; + +----------------------------------------------------------------- CXH3003_0 + +package CXH3003_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; + + Global_Variable : Boolean := False; + +end CXH3003_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- +with Report; +package body CXH3003_0 is + + procedure P(R:Root) is + Warnable : Positive := 0; -- OPTIONAL WARNING + 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; -- known to be initialized + end if; + end P; + + function F return A_Proc is + begin + return P'Access; + end F; + +end CXH3003_0; + +----------------------------------------------------------------- CXH3003_1 + +package CXH3003_0.CXH3003_1 is + + protected PT is + entry Set(Switch: Boolean); + function Enquire return Boolean; + private + Toggle : Boolean; + end PT; + + task TT is + entry Release; + end TT; + +end CXH3003_0.CXH3003_1; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +package body CXH3003_0.CXH3003_1 is + + 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; + + -- TT activation + +end CXH3003_0.CXH3003_1; + +------------------------------------------------------------------- CXH3003 + +with Report; +with CXH3003_0.CXH3003_1; +procedure CXH30031 is +begin + + Report.Test("CXH3003", "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; -- 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; + + CXH3003_0.CXH3003_1.PT.Set( A_Truth ); + + CXH3003_0.Global_Variable := A_Truth; + + CXH3003_0.CXH3003_1.TT.Release; -- rendezvous with TT + + while CXH3003_0.CXH3003_1.TT'Callable loop -- wait for TT to complete + delay 1.0; + end loop; + + if not CXH3003_0.CXH3003_1.PT.Enquire + or not CXH3003_0.Global_Variable then + Report.Failed(Message); + end if; + + end Block; + + Report.Result; + +end CXH30031; |