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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [cxh/] [cxh3001.a] - Blame information for rev 720

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- CXH3001.A
2
--
3
--                             Grant of Unlimited Rights
4
--
5
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
6
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
7
--     unlimited rights in the software and documentation contained herein.
8
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
9
--     this public release, the Government intends to confer upon all
10
--     recipients unlimited rights  equal to those held by the Government.
11
--     These rights include rights to use, duplicate, release or disclose the
12
--     released technical data and computer software in whole or in part, in
13
--     any manner and for any purpose whatsoever, and to have or permit others
14
--     to do so.
15
--
16
--                                    DISCLAIMER
17
--
18
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
19
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
20
--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
21
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
22
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
23
--     PARTICULAR PURPOSE OF SAID MATERIAL.
24
--*
25
--
26
-- OBJECTIVE
27
--     Check pragma Reviewable.
28
--     Check that pragma Reviewable is accepted as a configuration pragma.
29
--
30
-- TEST DESCRIPTION
31
--     The test requires that the configuration pragma Reviewable
32
--     be processed.  The following package contains a simple "one of each
33
--     construct in the language" to check that the configuration pragma has
34
--     not disallowed some feature of the language.  This test should generate
35
--     no errors.
36
--
37
-- APPLICABILITY CRITERIA:
38
--      This test is only applicable for a compiler attempting validation
39
--      for the Safety and Security Annex.
40
--
41
-- PASS/FAIL CRITERIA:
42
--      This test passes if it correctly compiles, executes, and reports PASS.
43
--      It fails if the pragma is rejected.  The effect of the pragma should
44
--      be to produce a listing with information, including warnings, as
45
--      required in H.3.1. Specific form and contents of this listing are not
46
--      required by this test and are not part of the PASS/FAIL criteria.
47
--
48
-- SPECIAL REQUIREMENTS
49
--      The implementation must process a configuration pragma which is not
50
--      part of any Compilation Unit; the method employed is implementation
51
--      defined.
52
--
53
--      Pragma Reviewable requires that the implementation provide the
54
--      following information for the compilation units in this test:
55
--
56
--        o Where compiler-generated run-time checks remain (6)
57
--
58
--        o Identification of any construct with a language-defined check
59
--          that is recognized prior to runtime as certain to fail if
60
--          executed (7)
61
--
62
--        o For each reference to a scalar object, an identification of
63
--          the reference as either "known to be initialized,"
64
--          or "possibly uninitialized" (8)
65
--
66
--        o Where run-time support routines are implicitly invoked (9)
67
--
68
--        o An object code listing including: (10)
69
--
70
--          o Machine instructions with relative offsets (11)
71
--
72
--          o Where each data object is stored during its lifetime (12)
73
--
74
--          o Correspondence with the source program (13)
75
--
76
--        o Identification of each construct for which the implementation
77
--          detects the possibility of erroneous execution (14)
78
--
79
--        o For each subprogram, block, task or other construct implemented by
80
--          reserving and subsequently freezing an area of the run-time stack,
81
--          an identification of the length of the fixed-size portion of
82
--          the area and an indication of whether the non-fixed size portion
83
--          is reserved on the stack or in a dynamically managed storage
84
--          region (15)
85
--
86
--
87
-- CHANGE HISTORY:
88
--      26 OCT 95   SAIC   Initial version
89
--      12 NOV 96   SAIC   Revised for 2.1
90
--      27 AUG 99   RLB    Removed result dependence on uninitialized object.
91
--      30 AUG 99   RLB    Repaired the above.
92
--
93
--!
94
 
95
---------------------------- CONFIGURATION PRAGMAS -----------------------
96
 
97
pragma Reviewable;                                                -- OK
98
                                                -- configuration pragma
99
 
100
------------------------ END OF CONFIGURATION PRAGMAS --------------------
101
 
102
 
103
----------------------------------------------------------------- CXH3001_0
104
 
105
package CXH3001_0 is
106
 
107
  type Enum is (Item,Stuff,Things);
108
 
109
  type Int is range 0..256;
110
 
111
  type Unt is mod 256;
112
 
113
  type Flt is digits 5;
114
 
115
  type Fix is delta 0.5 range -1.0..1.0;
116
 
117
  type Root(Disc: Enum) is tagged record
118
    I: Int; U:Unt;
119
  end record;
120
 
121
  type List is array(Unt) of Root(Stuff);
122
 
123
  type A_List is access List;
124
  type A_Proc is access procedure(R:Root);
125
 
126
  procedure P(R:Root);
127
 
128
  function F return A_Proc;
129
 
130
  protected PT is
131
    entry Set(Switch: Boolean);
132
    function Enquire return Boolean;
133
  private
134
    Toggle : Boolean;
135
  end PT;
136
 
137
  task TT is
138
    entry Release;
139
  end TT;
140
 
141
  Global_Variable : Boolean := False;
142
 
143
end CXH3001_0;
144
 
145
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
146
 
147
with Report;
148
package body CXH3001_0 is
149
 
150
 procedure P(R:Root) is
151
    Warnable : Positive := 0; -- (7)                      -- OPTIONAL WARNING
152
    -- this would raise Constraint_Error if P were ever called, however
153
    -- this test never calls P.
154
  begin
155
    case R.Disc is
156
      when Item   => Report.Comment("Got Item");
157
      when Stuff  => Report.Comment("Got Stuff");
158
      when Things => Report.Comment("Got Things");
159
    end case;
160
    if Report.Ident_Int( Warnable ) = 0 then
161
      Global_Variable := not Global_Variable; -- (8) known to be initialized
162
    end if;
163
  end P;
164
 
165
  function F return A_Proc is
166
  begin
167
    return P'Access;
168
  end F;
169
 
170
  protected body PT is
171
 
172
    entry Set(Switch: Boolean) when True is
173
    begin
174
      Toggle := Switch;
175
    end Set;
176
 
177
    function Enquire return Boolean is
178
    begin
179
      return Toggle;
180
    end Enquire;
181
 
182
  end PT;
183
 
184
  task body TT is
185
  begin
186
    loop
187
      accept Release;
188
      exit when Global_Variable;
189
    end loop;
190
  end TT;
191
 
192
  -- (9) TT activation
193
end CXH3001_0;
194
 
195
------------------------------------------------------------------- CXH3001
196
 
197
with Report;
198
with CXH3001_0;
199
procedure CXH3001 is
200
begin
201
  Report.Test("CXH3001", "Check pragma Reviewable as a configuration pragma");
202
 
203
  Block: declare
204
    A_Truth : Boolean;
205
    Message : String := Report.Ident_Str( "Bad value encountered" );
206
  begin
207
    begin
208
      A_Truth := Report.Ident_Bool( True ) or A_Truth;  -- (8) not initialized
209
      if not A_Truth then
210
        Report.Comment ("True or Uninit = False");
211
        A_Truth := Report.Ident_Bool (True);
212
      else
213
        A_Truth := Report.Ident_Bool (True);
214
          -- We do this separately on each branch in order to insure that a
215
          -- clever optimizer can find out little about this value. Ident_Bool
216
          -- is supposed to be opaque to any optimizer.
217
      end if;
218
    exception
219
      when Constraint_Error | Program_Error =>
220
           -- Possible results of accessing an uninitialized object.
221
        A_Truth := Report.Ident_Bool (True);
222
    end;
223
 
224
    CXH3001_0.PT.Set( A_Truth );
225
 
226
    CXH3001_0.Global_Variable := A_Truth;
227
 
228
    CXH3001_0.TT.Release;  -- (9) rendezvous with TT
229
 
230
    while CXH3001_0.TT'Callable loop
231
      delay 1.0; -- wait for TT to become non-callable
232
    end loop;
233
 
234
    if   not CXH3001_0.PT.Enquire
235
      or not CXH3001_0.Global_Variable
236
      or CXH3001_0.TT'Callable then
237
      Report.Failed(Message);
238
    end if;
239
 
240
  end Block;
241
 
242
  Report.Result;
243
end CXH3001;

powered by: WebSVN 2.1.0

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