summaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/cxh/cxh3001.a
blob: 4ed41b4d06f08ff32ad719e8e61f351a19a73d04 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
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;