OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

Compare Revisions

  • This comparison shows the changes necessary to convert path 
    /openrisc/trunk/gnu-old/gcc-4.2.2/gcc/testsuite/ada/acats/tests/cxh
    from Rev 154 to Rev 816
    ↔ Reverse comparison
  •

Rev 154 → Rev 816

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.