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