Mercurial > hg > CbC > CbC_gcc
comparison gcc/testsuite/ada/acats/tests/cxh/cxh30031.am @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
1 -- CXH30031.AM | |
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 -- This test checks that pragma Reviewable is processed as a | |
32 -- configuration pragma. See CXH3001 for testing pragma Reviewable as | |
33 -- other than a configuration pragma. | |
34 -- | |
35 -- TEST FILES: | |
36 -- The following files comprise this test: | |
37 -- | |
38 -- CXH30030.A | |
39 -- => CXH30031.AM | |
40 -- | |
41 -- APPLICABILITY CRITERIA: | |
42 -- This test is only applicable for a compiler attempting validation | |
43 -- for the Safety and Security Annex. | |
44 -- | |
45 -- SPECIAL REQUIREMENTS | |
46 -- The implementation must process a configuration pragma which is not | |
47 -- part of any Compilation Unit; the method employed is implementation | |
48 -- defined. | |
49 -- | |
50 -- | |
51 -- CHANGE HISTORY: | |
52 -- 26 OCT 95 SAIC Initial version for 2.1 | |
53 -- 07 JUN 96 SAIC Revised by reviewer request | |
54 -- 03 NOV 96 SAIC Documentation revision | |
55 -- | |
56 -- 03 NOV 96 Keith Documentation revision | |
57 -- 27 AUG 99 RLB Removed result dependence on uninitialized object. | |
58 -- 30 AUG 99 RLB Repaired the above. | |
59 -- | |
60 --! | |
61 | |
62 pragma Reviewable; | |
63 | |
64 ----------------------------------------------------------------- CXH3003_0 | |
65 | |
66 package CXH3003_0 is | |
67 | |
68 type Enum is (Item,Stuff,Things); | |
69 | |
70 type Int is range 0..256; | |
71 | |
72 type Unt is mod 256; | |
73 | |
74 type Flt is digits 5; | |
75 | |
76 type Fix is delta 0.5 range -1.0..1.0; | |
77 | |
78 type Root(Disc: Enum) is tagged record | |
79 I: Int; U:Unt; | |
80 end record; | |
81 | |
82 type List is array(Unt) of Root(Stuff); | |
83 | |
84 type A_List is access List; | |
85 type A_Proc is access procedure(R:Root); | |
86 | |
87 procedure P(R:Root); | |
88 | |
89 function F return A_Proc; | |
90 | |
91 Global_Variable : Boolean := False; | |
92 | |
93 end CXH3003_0; | |
94 | |
95 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- | |
96 with Report; | |
97 package body CXH3003_0 is | |
98 | |
99 procedure P(R:Root) is | |
100 Warnable : Positive := 0; -- OPTIONAL WARNING | |
101 begin | |
102 case R.Disc is | |
103 when Item => Report.Comment("Got Item"); | |
104 when Stuff => Report.Comment("Got Stuff"); | |
105 when Things => Report.Comment("Got Things"); | |
106 end case; | |
107 if Report.Ident_Int( Warnable ) = 0 then | |
108 Global_Variable := not Global_Variable; -- known to be initialized | |
109 end if; | |
110 end P; | |
111 | |
112 function F return A_Proc is | |
113 begin | |
114 return P'Access; | |
115 end F; | |
116 | |
117 end CXH3003_0; | |
118 | |
119 ----------------------------------------------------------------- CXH3003_1 | |
120 | |
121 package CXH3003_0.CXH3003_1 is | |
122 | |
123 protected PT is | |
124 entry Set(Switch: Boolean); | |
125 function Enquire return Boolean; | |
126 private | |
127 Toggle : Boolean; | |
128 end PT; | |
129 | |
130 task TT is | |
131 entry Release; | |
132 end TT; | |
133 | |
134 end CXH3003_0.CXH3003_1; | |
135 | |
136 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- | |
137 | |
138 package body CXH3003_0.CXH3003_1 is | |
139 | |
140 protected body PT is | |
141 | |
142 entry Set(Switch: Boolean) when True is | |
143 begin | |
144 Toggle := Switch; | |
145 end Set; | |
146 | |
147 function Enquire return Boolean is | |
148 begin | |
149 return Toggle; | |
150 end Enquire; | |
151 | |
152 end PT; | |
153 | |
154 task body TT is | |
155 begin | |
156 loop | |
157 accept Release; | |
158 exit when Global_Variable; | |
159 end loop; | |
160 end TT; | |
161 | |
162 -- TT activation | |
163 | |
164 end CXH3003_0.CXH3003_1; | |
165 | |
166 ------------------------------------------------------------------- CXH3003 | |
167 | |
168 with Report; | |
169 with CXH3003_0.CXH3003_1; | |
170 procedure CXH30031 is | |
171 begin | |
172 | |
173 Report.Test("CXH3003", "Check pragma Reviewable as a configuration pragma"); | |
174 | |
175 Block: declare | |
176 A_Truth : Boolean; | |
177 Message : String := Report.Ident_Str( "Bad value encountered" ); | |
178 begin | |
179 begin | |
180 A_Truth := Report.Ident_Bool( True ) or A_Truth; -- not initialized | |
181 if not A_Truth then | |
182 Report.Comment ("True or Uninit = False"); | |
183 A_Truth := Report.Ident_Bool (True); | |
184 else | |
185 A_Truth := Report.Ident_Bool (True); | |
186 -- We do this separately on each branch in order to insure that a | |
187 -- clever optimizer can find out little about this value. Ident_Bool | |
188 -- is supposed to be opaque to any optimizer. | |
189 end if; | |
190 exception | |
191 when Constraint_Error | Program_Error => | |
192 -- Possible results of accessing an uninitialized object. | |
193 A_Truth := Report.Ident_Bool (True); | |
194 end; | |
195 | |
196 CXH3003_0.CXH3003_1.PT.Set( A_Truth ); | |
197 | |
198 CXH3003_0.Global_Variable := A_Truth; | |
199 | |
200 CXH3003_0.CXH3003_1.TT.Release; -- rendezvous with TT | |
201 | |
202 while CXH3003_0.CXH3003_1.TT'Callable loop -- wait for TT to complete | |
203 delay 1.0; | |
204 end loop; | |
205 | |
206 if not CXH3003_0.CXH3003_1.PT.Enquire | |
207 or not CXH3003_0.Global_Variable then | |
208 Report.Failed(Message); | |
209 end if; | |
210 | |
211 end Block; | |
212 | |
213 Report.Result; | |
214 | |
215 end CXH30031; |