|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- E X P _ P R A G --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
|
|
111
|
10 -- --
|
|
|
11 -- GNAT is free software; you can redistribute it and/or modify it under --
|
|
|
12 -- terms of the GNU General Public License as published by the Free Soft- --
|
|
|
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
|
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
|
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
|
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
|
|
17 -- for more details. You should have received a copy of the GNU General --
|
|
|
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
|
|
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
|
|
|
20 -- --
|
|
|
21 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
23 -- --
|
|
|
24 ------------------------------------------------------------------------------
|
|
|
25
|
|
|
26 with Atree; use Atree;
|
|
|
27 with Casing; use Casing;
|
|
|
28 with Checks; use Checks;
|
|
|
29 with Debug; use Debug;
|
|
|
30 with Einfo; use Einfo;
|
|
|
31 with Errout; use Errout;
|
|
|
32 with Exp_Ch11; use Exp_Ch11;
|
|
|
33 with Exp_Util; use Exp_Util;
|
|
|
34 with Expander; use Expander;
|
|
|
35 with Inline; use Inline;
|
|
|
36 with Lib; use Lib;
|
|
|
37 with Namet; use Namet;
|
|
|
38 with Nlists; use Nlists;
|
|
|
39 with Nmake; use Nmake;
|
|
|
40 with Opt; use Opt;
|
|
|
41 with Restrict; use Restrict;
|
|
|
42 with Rident; use Rident;
|
|
|
43 with Rtsfind; use Rtsfind;
|
|
|
44 with Sem; use Sem;
|
|
|
45 with Sem_Aux; use Sem_Aux;
|
|
|
46 with Sem_Ch8; use Sem_Ch8;
|
|
131
|
47 with Sem_Prag; use Sem_Prag;
|
|
111
|
48 with Sem_Util; use Sem_Util;
|
|
|
49 with Sinfo; use Sinfo;
|
|
|
50 with Sinput; use Sinput;
|
|
|
51 with Snames; use Snames;
|
|
|
52 with Stringt; use Stringt;
|
|
|
53 with Stand; use Stand;
|
|
|
54 with Tbuild; use Tbuild;
|
|
|
55 with Uintp; use Uintp;
|
|
|
56 with Validsw; use Validsw;
|
|
|
57
|
|
|
58 package body Exp_Prag is
|
|
|
59
|
|
|
60 -----------------------
|
|
|
61 -- Local Subprograms --
|
|
|
62 -----------------------
|
|
|
63
|
|
|
64 function Arg1 (N : Node_Id) return Node_Id;
|
|
|
65 function Arg2 (N : Node_Id) return Node_Id;
|
|
|
66 function Arg3 (N : Node_Id) return Node_Id;
|
|
|
67 -- Obtain specified pragma argument expression
|
|
|
68
|
|
|
69 procedure Expand_Pragma_Abort_Defer (N : Node_Id);
|
|
|
70 procedure Expand_Pragma_Check (N : Node_Id);
|
|
|
71 procedure Expand_Pragma_Common_Object (N : Node_Id);
|
|
|
72 procedure Expand_Pragma_Import_Or_Interface (N : Node_Id);
|
|
|
73 procedure Expand_Pragma_Inspection_Point (N : Node_Id);
|
|
|
74 procedure Expand_Pragma_Interrupt_Priority (N : Node_Id);
|
|
|
75 procedure Expand_Pragma_Loop_Variant (N : Node_Id);
|
|
|
76 procedure Expand_Pragma_Psect_Object (N : Node_Id);
|
|
|
77 procedure Expand_Pragma_Relative_Deadline (N : Node_Id);
|
|
|
78 procedure Expand_Pragma_Suppress_Initialization (N : Node_Id);
|
|
|
79
|
|
|
80 procedure Undo_Initialization (Def_Id : Entity_Id; N : Node_Id);
|
|
|
81 -- This procedure is used to undo initialization already done for Def_Id,
|
|
|
82 -- which is always an E_Variable, in response to the occurrence of the
|
|
|
83 -- pragma N, a pragma Interface, Import, or Suppress_Initialization. In all
|
|
|
84 -- these cases we want no initialization to occur, but we have already done
|
|
|
85 -- the initialization by the time we see the pragma, so we have to undo it.
|
|
|
86
|
|
|
87 ----------
|
|
|
88 -- Arg1 --
|
|
|
89 ----------
|
|
|
90
|
|
|
91 function Arg1 (N : Node_Id) return Node_Id is
|
|
|
92 Arg : constant Node_Id := First (Pragma_Argument_Associations (N));
|
|
|
93 begin
|
|
|
94 if Present (Arg)
|
|
|
95 and then Nkind (Arg) = N_Pragma_Argument_Association
|
|
|
96 then
|
|
|
97 return Expression (Arg);
|
|
|
98 else
|
|
|
99 return Arg;
|
|
|
100 end if;
|
|
|
101 end Arg1;
|
|
|
102
|
|
|
103 ----------
|
|
|
104 -- Arg2 --
|
|
|
105 ----------
|
|
|
106
|
|
|
107 function Arg2 (N : Node_Id) return Node_Id is
|
|
|
108 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
|
|
|
109
|
|
|
110 begin
|
|
|
111 if No (Arg1) then
|
|
|
112 return Empty;
|
|
|
113
|
|
|
114 else
|
|
|
115 declare
|
|
|
116 Arg : constant Node_Id := Next (Arg1);
|
|
|
117 begin
|
|
|
118 if Present (Arg)
|
|
|
119 and then Nkind (Arg) = N_Pragma_Argument_Association
|
|
|
120 then
|
|
|
121 return Expression (Arg);
|
|
|
122 else
|
|
|
123 return Arg;
|
|
|
124 end if;
|
|
|
125 end;
|
|
|
126 end if;
|
|
|
127 end Arg2;
|
|
|
128
|
|
|
129 ----------
|
|
|
130 -- Arg3 --
|
|
|
131 ----------
|
|
|
132
|
|
|
133 function Arg3 (N : Node_Id) return Node_Id is
|
|
|
134 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
|
|
|
135
|
|
|
136 begin
|
|
|
137 if No (Arg1) then
|
|
|
138 return Empty;
|
|
|
139
|
|
|
140 else
|
|
|
141 declare
|
|
|
142 Arg : Node_Id := Next (Arg1);
|
|
|
143 begin
|
|
|
144 if No (Arg) then
|
|
|
145 return Empty;
|
|
|
146
|
|
|
147 else
|
|
|
148 Next (Arg);
|
|
|
149
|
|
|
150 if Present (Arg)
|
|
|
151 and then Nkind (Arg) = N_Pragma_Argument_Association
|
|
|
152 then
|
|
|
153 return Expression (Arg);
|
|
|
154 else
|
|
|
155 return Arg;
|
|
|
156 end if;
|
|
|
157 end if;
|
|
|
158 end;
|
|
|
159 end if;
|
|
|
160 end Arg3;
|
|
|
161
|
|
|
162 ---------------------
|
|
|
163 -- Expand_N_Pragma --
|
|
|
164 ---------------------
|
|
|
165
|
|
|
166 procedure Expand_N_Pragma (N : Node_Id) is
|
|
|
167 Pname : constant Name_Id := Pragma_Name (N);
|
|
|
168 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
|
|
|
169
|
|
|
170 begin
|
|
131
|
171 -- Suppress the expansion of an ignored assertion pragma. Such a pragma
|
|
|
172 -- should not be transformed into a null statment because:
|
|
|
173 --
|
|
|
174 -- * The pragma may be part of the rep item chain of a type, in which
|
|
|
175 -- case rewriting it will destroy the chain.
|
|
|
176 --
|
|
|
177 -- * The analysis of the pragma may involve two parts (see routines
|
|
|
178 -- Analyze_xxx_In_Decl_Part). The second part of the analysis will
|
|
|
179 -- not happen if the pragma is rewritten.
|
|
|
180
|
|
|
181 if Assertion_Expression_Pragma (Prag_Id) and then Is_Ignored (N) then
|
|
|
182 return;
|
|
|
183
|
|
|
184 -- Rewrite the pragma into a null statement when it is ignored using
|
|
|
185 -- pragma Ignore_Pragma, or denotes Default_Scalar_Storage_Order and
|
|
|
186 -- compilation switch -gnatI is in effect.
|
|
|
187
|
|
|
188 elsif Should_Ignore_Pragma_Sem (N)
|
|
111
|
189 or else (Prag_Id = Pragma_Default_Scalar_Storage_Order
|
|
|
190 and then Ignore_Rep_Clauses)
|
|
|
191 then
|
|
|
192 Rewrite (N, Make_Null_Statement (Sloc (N)));
|
|
|
193 return;
|
|
|
194 end if;
|
|
|
195
|
|
|
196 case Prag_Id is
|
|
|
197
|
|
|
198 -- Pragmas requiring special expander action
|
|
|
199
|
|
|
200 when Pragma_Abort_Defer =>
|
|
|
201 Expand_Pragma_Abort_Defer (N);
|
|
|
202
|
|
|
203 when Pragma_Check =>
|
|
|
204 Expand_Pragma_Check (N);
|
|
|
205
|
|
|
206 when Pragma_Common_Object =>
|
|
|
207 Expand_Pragma_Common_Object (N);
|
|
|
208
|
|
|
209 when Pragma_Import =>
|
|
|
210 Expand_Pragma_Import_Or_Interface (N);
|
|
|
211
|
|
|
212 when Pragma_Inspection_Point =>
|
|
|
213 Expand_Pragma_Inspection_Point (N);
|
|
|
214
|
|
|
215 when Pragma_Interface =>
|
|
|
216 Expand_Pragma_Import_Or_Interface (N);
|
|
|
217
|
|
|
218 when Pragma_Interrupt_Priority =>
|
|
|
219 Expand_Pragma_Interrupt_Priority (N);
|
|
|
220
|
|
|
221 when Pragma_Loop_Variant =>
|
|
|
222 Expand_Pragma_Loop_Variant (N);
|
|
|
223
|
|
|
224 when Pragma_Psect_Object =>
|
|
|
225 Expand_Pragma_Psect_Object (N);
|
|
|
226
|
|
|
227 when Pragma_Relative_Deadline =>
|
|
|
228 Expand_Pragma_Relative_Deadline (N);
|
|
|
229
|
|
|
230 when Pragma_Suppress_Initialization =>
|
|
|
231 Expand_Pragma_Suppress_Initialization (N);
|
|
|
232
|
|
|
233 -- All other pragmas need no expander action (includes
|
|
|
234 -- Unknown_Pragma).
|
|
|
235
|
|
|
236 when others => null;
|
|
|
237 end case;
|
|
|
238 end Expand_N_Pragma;
|
|
|
239
|
|
|
240 -------------------------------
|
|
|
241 -- Expand_Pragma_Abort_Defer --
|
|
|
242 -------------------------------
|
|
|
243
|
|
|
244 -- An Abort_Defer pragma appears as the first statement in a handled
|
|
|
245 -- statement sequence (right after the begin). It defers aborts for
|
|
|
246 -- the entire statement sequence, but not for any declarations or
|
|
|
247 -- handlers (if any) associated with this statement sequence.
|
|
|
248
|
|
|
249 -- The transformation is to transform
|
|
|
250
|
|
|
251 -- pragma Abort_Defer;
|
|
|
252 -- statements;
|
|
|
253
|
|
|
254 -- into
|
|
|
255
|
|
|
256 -- begin
|
|
|
257 -- Abort_Defer.all;
|
|
|
258 -- statements
|
|
|
259 -- exception
|
|
|
260 -- when all others =>
|
|
|
261 -- Abort_Undefer.all;
|
|
|
262 -- raise;
|
|
|
263 -- at end
|
|
|
264 -- Abort_Undefer_Direct;
|
|
|
265 -- end;
|
|
|
266
|
|
|
267 procedure Expand_Pragma_Abort_Defer (N : Node_Id) is
|
|
|
268 begin
|
|
|
269 -- Abort_Defer has no useful effect if Abort's are not allowed
|
|
|
270
|
|
|
271 if not Abort_Allowed then
|
|
|
272 return;
|
|
|
273 end if;
|
|
|
274
|
|
|
275 -- Normal case where abort is possible
|
|
|
276
|
|
|
277 declare
|
|
|
278 Loc : constant Source_Ptr := Sloc (N);
|
|
|
279 Stm : Node_Id;
|
|
|
280 Stms : List_Id;
|
|
|
281 HSS : Node_Id;
|
|
|
282 Blk : constant Entity_Id :=
|
|
|
283 New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');
|
|
|
284 AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct);
|
|
|
285
|
|
|
286 begin
|
|
|
287 Stms := New_List (Build_Runtime_Call (Loc, RE_Abort_Defer));
|
|
|
288 loop
|
|
|
289 Stm := Remove_Next (N);
|
|
|
290 exit when No (Stm);
|
|
|
291 Append (Stm, Stms);
|
|
|
292 end loop;
|
|
|
293
|
|
|
294 HSS :=
|
|
|
295 Make_Handled_Sequence_Of_Statements (Loc,
|
|
|
296 Statements => Stms,
|
|
|
297 At_End_Proc => New_Occurrence_Of (AUD, Loc));
|
|
|
298
|
|
|
299 -- Present the Abort_Undefer_Direct function to the backend so that
|
|
|
300 -- it can inline the call to the function.
|
|
|
301
|
|
|
302 Add_Inlined_Body (AUD, N);
|
|
|
303
|
|
|
304 Rewrite (N,
|
|
|
305 Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS));
|
|
|
306
|
|
|
307 Set_Scope (Blk, Current_Scope);
|
|
|
308 Set_Etype (Blk, Standard_Void_Type);
|
|
|
309 Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N)));
|
|
|
310 Expand_At_End_Handler (HSS, Blk);
|
|
|
311 Analyze (N);
|
|
|
312 end;
|
|
|
313 end Expand_Pragma_Abort_Defer;
|
|
|
314
|
|
|
315 --------------------------
|
|
|
316 -- Expand_Pragma_Check --
|
|
|
317 --------------------------
|
|
|
318
|
|
|
319 procedure Expand_Pragma_Check (N : Node_Id) is
|
|
|
320 Cond : constant Node_Id := Arg2 (N);
|
|
|
321 Nam : constant Name_Id := Chars (Arg1 (N));
|
|
|
322 Msg : Node_Id;
|
|
|
323
|
|
|
324 Loc : constant Source_Ptr := Sloc (First_Node (Cond));
|
|
|
325 -- Source location used in the case of a failed assertion: point to the
|
|
|
326 -- failing condition, not Loc. Note that the source location of the
|
|
|
327 -- expression is not usually the best choice here, because it points to
|
|
|
328 -- the location of the topmost tree node, which may be an operator in
|
|
|
329 -- the middle of the source text of the expression. For example, it gets
|
|
|
330 -- located on the last AND keyword in a chain of boolean expressiond
|
|
|
331 -- AND'ed together. It is best to put the message on the first character
|
|
|
332 -- of the condition, which is the effect of the First_Node call here.
|
|
|
333 -- This source location is used to build the default exception message,
|
|
|
334 -- and also as the sloc of the call to the runtime subprogram raising
|
|
|
335 -- Assert_Failure, so that coverage analysis tools can relate the
|
|
|
336 -- call to the failed check.
|
|
|
337
|
|
|
338 procedure Replace_Discriminals_Of_Protected_Op (Expr : Node_Id);
|
|
|
339 -- Discriminants of the enclosing protected object may be referenced
|
|
|
340 -- in the expression of a precondition of a protected operation.
|
|
|
341 -- In the body of the operation these references must be replaced by
|
|
|
342 -- the discriminal created for them, which are renamings of the
|
|
|
343 -- discriminants of the object that is the target of the operation.
|
|
|
344 -- This replacement is done by visibility when the references appear
|
|
|
345 -- in the subprogram body, but in the case of a condition which appears
|
|
|
346 -- on the specification of the subprogram it has be done separately
|
|
|
347 -- because the condition has been replaced by a Check pragma and
|
|
|
348 -- analyzed earlier, before the creation of the discriminal renaming
|
|
|
349 -- declarations that are added to the subprogram body.
|
|
|
350
|
|
|
351 ------------------------------------------
|
|
|
352 -- Replace_Discriminals_Of_Protected_Op --
|
|
|
353 ------------------------------------------
|
|
|
354
|
|
|
355 procedure Replace_Discriminals_Of_Protected_Op (Expr : Node_Id) is
|
|
|
356 function Find_Corresponding_Discriminal
|
|
|
357 (E : Entity_Id) return Entity_Id;
|
|
|
358 -- Find the local entity that renames a discriminant of the enclosing
|
|
|
359 -- protected type, and has a matching name.
|
|
|
360
|
|
|
361 function Replace_Discr_Ref (N : Node_Id) return Traverse_Result;
|
|
|
362 -- Replace a reference to a discriminant of the original protected
|
|
|
363 -- type by the local renaming declaration of the discriminant of
|
|
|
364 -- the target object.
|
|
|
365
|
|
|
366 ------------------------------------
|
|
|
367 -- Find_Corresponding_Discriminal --
|
|
|
368 ------------------------------------
|
|
|
369
|
|
|
370 function Find_Corresponding_Discriminal
|
|
|
371 (E : Entity_Id) return Entity_Id
|
|
|
372 is
|
|
|
373 R : Entity_Id;
|
|
|
374
|
|
|
375 begin
|
|
|
376 R := First_Entity (Current_Scope);
|
|
|
377
|
|
|
378 while Present (R) loop
|
|
|
379 if Nkind (Parent (R)) = N_Object_Renaming_Declaration
|
|
|
380 and then Present (Discriminal_Link (R))
|
|
|
381 and then Chars (Discriminal_Link (R)) = Chars (E)
|
|
|
382 then
|
|
|
383 return R;
|
|
|
384 end if;
|
|
|
385
|
|
|
386 Next_Entity (R);
|
|
|
387 end loop;
|
|
|
388
|
|
|
389 return Empty;
|
|
|
390 end Find_Corresponding_Discriminal;
|
|
|
391
|
|
|
392 -----------------------
|
|
|
393 -- Replace_Discr_Ref --
|
|
|
394 -----------------------
|
|
|
395
|
|
|
396 function Replace_Discr_Ref (N : Node_Id) return Traverse_Result is
|
|
|
397 R : Entity_Id;
|
|
|
398
|
|
|
399 begin
|
|
|
400 if Is_Entity_Name (N)
|
|
|
401 and then Present (Discriminal_Link (Entity (N)))
|
|
|
402 then
|
|
|
403 R := Find_Corresponding_Discriminal (Entity (N));
|
|
|
404 Rewrite (N, New_Occurrence_Of (R, Sloc (N)));
|
|
|
405 end if;
|
|
|
406
|
|
|
407 return OK;
|
|
|
408 end Replace_Discr_Ref;
|
|
|
409
|
|
|
410 procedure Replace_Discriminant_References is
|
|
|
411 new Traverse_Proc (Replace_Discr_Ref);
|
|
|
412
|
|
|
413 -- Start of processing for Replace_Discriminals_Of_Protected_Op
|
|
|
414
|
|
|
415 begin
|
|
|
416 Replace_Discriminant_References (Expr);
|
|
|
417 end Replace_Discriminals_Of_Protected_Op;
|
|
|
418
|
|
|
419 -- Start of processing for Expand_Pragma_Check
|
|
|
420
|
|
|
421 begin
|
|
|
422 -- Nothing to do if pragma is ignored
|
|
|
423
|
|
|
424 if Is_Ignored (N) then
|
|
|
425 return;
|
|
|
426 end if;
|
|
|
427
|
|
|
428 -- Since this check is active, rewrite the pragma into a corresponding
|
|
|
429 -- if statement, and then analyze the statement.
|
|
|
430
|
|
|
431 -- The normal case expansion transforms:
|
|
|
432
|
|
|
433 -- pragma Check (name, condition [,message]);
|
|
|
434
|
|
|
435 -- into
|
|
|
436
|
|
|
437 -- if not condition then
|
|
|
438 -- System.Assertions.Raise_Assert_Failure (Str);
|
|
|
439 -- end if;
|
|
|
440
|
|
|
441 -- where Str is the message if one is present, or the default of
|
|
|
442 -- name failed at file:line if no message is given (the "name failed
|
|
|
443 -- at" is omitted for name = Assertion, since it is redundant, given
|
|
|
444 -- that the name of the exception is Assert_Failure.)
|
|
|
445
|
|
|
446 -- Also, instead of "XXX failed at", we generate slightly
|
|
|
447 -- different messages for some of the contract assertions (see
|
|
|
448 -- code below for details).
|
|
|
449
|
|
|
450 -- An alternative expansion is used when the No_Exception_Propagation
|
|
|
451 -- restriction is active and there is a local Assert_Failure handler.
|
|
|
452 -- This is not a common combination of circumstances, but it occurs in
|
|
|
453 -- the context of Aunit and the zero footprint profile. In this case we
|
|
|
454 -- generate:
|
|
|
455
|
|
|
456 -- if not condition then
|
|
|
457 -- raise Assert_Failure;
|
|
|
458 -- end if;
|
|
|
459
|
|
|
460 -- This will then be transformed into a goto, and the local handler will
|
|
|
461 -- be able to handle the assert error (which would not be the case if a
|
|
|
462 -- call is made to the Raise_Assert_Failure procedure).
|
|
|
463
|
|
|
464 -- We also generate the direct raise if the Suppress_Exception_Locations
|
|
|
465 -- is active, since we don't want to generate messages in this case.
|
|
|
466
|
|
|
467 -- Note that the reason we do not always generate a direct raise is that
|
|
|
468 -- the form in which the procedure is called allows for more efficient
|
|
|
469 -- breakpointing of assertion errors.
|
|
|
470
|
|
|
471 -- Generate the appropriate if statement. Note that we consider this to
|
|
|
472 -- be an explicit conditional in the source, not an implicit if, so we
|
|
|
473 -- do not call Make_Implicit_If_Statement.
|
|
|
474
|
|
|
475 -- Case where we generate a direct raise
|
|
|
476
|
|
|
477 if ((Debug_Flag_Dot_G
|
|
|
478 or else Restriction_Active (No_Exception_Propagation))
|
|
|
479 and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N)))
|
|
|
480 or else (Opt.Exception_Locations_Suppressed and then No (Arg3 (N)))
|
|
|
481 then
|
|
|
482 Rewrite (N,
|
|
|
483 Make_If_Statement (Loc,
|
|
|
484 Condition => Make_Op_Not (Loc, Right_Opnd => Cond),
|
|
|
485 Then_Statements => New_List (
|
|
|
486 Make_Raise_Statement (Loc,
|
|
|
487 Name => New_Occurrence_Of (RTE (RE_Assert_Failure), Loc)))));
|
|
|
488
|
|
|
489 -- Case where we call the procedure
|
|
|
490
|
|
|
491 else
|
|
|
492 -- If we have a message given, use it
|
|
|
493
|
|
|
494 if Present (Arg3 (N)) then
|
|
|
495 Msg := Get_Pragma_Arg (Arg3 (N));
|
|
|
496
|
|
|
497 -- Here we have no string, so prepare one
|
|
|
498
|
|
|
499 else
|
|
|
500 declare
|
|
|
501 Loc_Str : constant String := Build_Location_String (Loc);
|
|
|
502
|
|
|
503 begin
|
|
|
504 Name_Len := 0;
|
|
|
505
|
|
|
506 -- For Assert, we just use the location
|
|
|
507
|
|
|
508 if Nam = Name_Assert then
|
|
|
509 null;
|
|
|
510
|
|
|
511 -- For predicate, we generate the string "predicate failed at
|
|
|
512 -- yyy". We prefer all lower case for predicate.
|
|
|
513
|
|
|
514 elsif Nam = Name_Predicate then
|
|
|
515 Add_Str_To_Name_Buffer ("predicate failed at ");
|
|
|
516
|
|
|
517 -- For special case of Precondition/Postcondition the string is
|
|
|
518 -- "failed xx from yy" where xx is precondition/postcondition
|
|
|
519 -- in all lower case. The reason for this different wording is
|
|
|
520 -- that the failure is not at the point of occurrence of the
|
|
|
521 -- pragma, unlike the other Check cases.
|
|
|
522
|
|
|
523 elsif Nam_In (Nam, Name_Precondition, Name_Postcondition) then
|
|
|
524 Get_Name_String (Nam);
|
|
|
525 Insert_Str_In_Name_Buffer ("failed ", 1);
|
|
|
526 Add_Str_To_Name_Buffer (" from ");
|
|
|
527
|
|
|
528 -- For special case of Invariant, the string is "failed
|
|
|
529 -- invariant from yy", to be consistent with the string that is
|
|
|
530 -- generated for the aspect case (the code later on checks for
|
|
|
531 -- this specific string to modify it in some cases, so this is
|
|
|
532 -- functionally important).
|
|
|
533
|
|
|
534 elsif Nam = Name_Invariant then
|
|
|
535 Add_Str_To_Name_Buffer ("failed invariant from ");
|
|
|
536
|
|
|
537 -- For all other checks, the string is "xxx failed at yyy"
|
|
|
538 -- where xxx is the check name with appropriate casing.
|
|
|
539
|
|
|
540 else
|
|
|
541 Get_Name_String (Nam);
|
|
|
542 Set_Casing
|
|
|
543 (Identifier_Casing (Source_Index (Current_Sem_Unit)));
|
|
|
544 Add_Str_To_Name_Buffer (" failed at ");
|
|
|
545 end if;
|
|
|
546
|
|
|
547 -- In all cases, add location string
|
|
|
548
|
|
|
549 Add_Str_To_Name_Buffer (Loc_Str);
|
|
|
550
|
|
|
551 -- Build the message
|
|
|
552
|
|
|
553 Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len));
|
|
|
554 end;
|
|
|
555 end if;
|
|
|
556
|
|
|
557 -- For a precondition, replace references to discriminants of a
|
|
|
558 -- protected type with the local discriminals.
|
|
|
559
|
|
|
560 if Is_Protected_Type (Scope (Current_Scope))
|
|
|
561 and then Has_Discriminants (Scope (Current_Scope))
|
|
|
562 and then From_Aspect_Specification (N)
|
|
|
563 then
|
|
|
564 Replace_Discriminals_Of_Protected_Op (Cond);
|
|
|
565 end if;
|
|
|
566
|
|
|
567 -- Now rewrite as an if statement
|
|
|
568
|
|
|
569 Rewrite (N,
|
|
|
570 Make_If_Statement (Loc,
|
|
|
571 Condition => Make_Op_Not (Loc, Right_Opnd => Cond),
|
|
|
572 Then_Statements => New_List (
|
|
|
573 Make_Procedure_Call_Statement (Loc,
|
|
|
574 Name =>
|
|
|
575 New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc),
|
|
|
576 Parameter_Associations => New_List (Relocate_Node (Msg))))));
|
|
|
577 end if;
|
|
|
578
|
|
|
579 Analyze (N);
|
|
|
580
|
|
|
581 -- If new condition is always false, give a warning
|
|
|
582
|
|
|
583 if Warn_On_Assertion_Failure
|
|
|
584 and then Nkind (N) = N_Procedure_Call_Statement
|
|
|
585 and then Is_RTE (Entity (Name (N)), RE_Raise_Assert_Failure)
|
|
|
586 then
|
|
|
587 -- If original condition was a Standard.False, we assume that this is
|
|
|
588 -- indeed intended to raise assert error and no warning is required.
|
|
|
589
|
|
|
590 if Is_Entity_Name (Original_Node (Cond))
|
|
|
591 and then Entity (Original_Node (Cond)) = Standard_False
|
|
|
592 then
|
|
|
593 null;
|
|
|
594
|
|
|
595 elsif Nam = Name_Assert then
|
|
|
596 Error_Msg_N ("?A?assertion will fail at run time", N);
|
|
|
597 else
|
|
|
598 Error_Msg_N ("?A?check will fail at run time", N);
|
|
|
599 end if;
|
|
|
600 end if;
|
|
|
601 end Expand_Pragma_Check;
|
|
|
602
|
|
|
603 ---------------------------------
|
|
|
604 -- Expand_Pragma_Common_Object --
|
|
|
605 ---------------------------------
|
|
|
606
|
|
|
607 -- Use a machine attribute to replicate semantic effect in DEC Ada
|
|
|
608
|
|
|
609 -- pragma Machine_Attribute (intern_name, "common_object", extern_name);
|
|
|
610
|
|
|
611 -- For now we do nothing with the size attribute ???
|
|
|
612
|
|
|
613 -- Note: Psect_Object shares this processing
|
|
|
614
|
|
|
615 procedure Expand_Pragma_Common_Object (N : Node_Id) is
|
|
|
616 Loc : constant Source_Ptr := Sloc (N);
|
|
|
617
|
|
|
618 Internal : constant Node_Id := Arg1 (N);
|
|
|
619 External : constant Node_Id := Arg2 (N);
|
|
|
620
|
|
|
621 Psect : Node_Id;
|
|
|
622 -- Psect value upper cased as string literal
|
|
|
623
|
|
|
624 Iloc : constant Source_Ptr := Sloc (Internal);
|
|
|
625 Eloc : constant Source_Ptr := Sloc (External);
|
|
|
626 Ploc : Source_Ptr;
|
|
|
627
|
|
|
628 begin
|
|
|
629 -- Acquire Psect value and fold to upper case
|
|
|
630
|
|
|
631 if Present (External) then
|
|
|
632 if Nkind (External) = N_String_Literal then
|
|
|
633 String_To_Name_Buffer (Strval (External));
|
|
|
634 else
|
|
|
635 Get_Name_String (Chars (External));
|
|
|
636 end if;
|
|
|
637
|
|
|
638 Set_All_Upper_Case;
|
|
|
639
|
|
|
640 Psect :=
|
|
|
641 Make_String_Literal (Eloc, Strval => String_From_Name_Buffer);
|
|
|
642
|
|
|
643 else
|
|
|
644 Get_Name_String (Chars (Internal));
|
|
|
645 Set_All_Upper_Case;
|
|
|
646 Psect :=
|
|
|
647 Make_String_Literal (Iloc, Strval => String_From_Name_Buffer);
|
|
|
648 end if;
|
|
|
649
|
|
|
650 Ploc := Sloc (Psect);
|
|
|
651
|
|
|
652 -- Insert the pragma
|
|
|
653
|
|
|
654 Insert_After_And_Analyze (N,
|
|
|
655 Make_Pragma (Loc,
|
|
|
656 Chars => Name_Machine_Attribute,
|
|
|
657 Pragma_Argument_Associations => New_List (
|
|
|
658 Make_Pragma_Argument_Association (Iloc,
|
|
|
659 Expression => New_Copy_Tree (Internal)),
|
|
|
660 Make_Pragma_Argument_Association (Eloc,
|
|
|
661 Expression =>
|
|
|
662 Make_String_Literal (Sloc => Ploc, Strval => "common_object")),
|
|
|
663 Make_Pragma_Argument_Association (Ploc,
|
|
|
664 Expression => New_Copy_Tree (Psect)))));
|
|
|
665 end Expand_Pragma_Common_Object;
|
|
|
666
|
|
|
667 ----------------------------------
|
|
|
668 -- Expand_Pragma_Contract_Cases --
|
|
|
669 ----------------------------------
|
|
|
670
|
|
|
671 -- Pragma Contract_Cases is expanded in the following manner:
|
|
|
672
|
|
|
673 -- subprogram S is
|
|
|
674 -- Count : Natural := 0;
|
|
|
675 -- Flag_1 : Boolean := False;
|
|
|
676 -- . . .
|
|
|
677 -- Flag_N : Boolean := False;
|
|
|
678 -- Flag_N+1 : Boolean := False; -- when "others" present
|
|
|
679 -- Pref_1 : ...;
|
|
|
680 -- . . .
|
|
|
681 -- Pref_M : ...;
|
|
|
682
|
|
|
683 -- <preconditions (if any)>
|
|
|
684
|
|
|
685 -- -- Evaluate all case guards
|
|
|
686
|
|
|
687 -- if Case_Guard_1 then
|
|
|
688 -- Flag_1 := True;
|
|
|
689 -- Count := Count + 1;
|
|
|
690 -- end if;
|
|
|
691 -- . . .
|
|
|
692 -- if Case_Guard_N then
|
|
|
693 -- Flag_N := True;
|
|
|
694 -- Count := Count + 1;
|
|
|
695 -- end if;
|
|
|
696
|
|
|
697 -- -- Emit errors depending on the number of case guards that
|
|
|
698 -- -- evaluated to True.
|
|
|
699
|
|
|
700 -- if Count = 0 then
|
|
|
701 -- raise Assertion_Error with "xxx contract cases incomplete";
|
|
|
702 -- <or>
|
|
|
703 -- Flag_N+1 := True; -- when "others" present
|
|
|
704
|
|
|
705 -- elsif Count > 1 then
|
|
|
706 -- declare
|
|
|
707 -- Str0 : constant String :=
|
|
|
708 -- "contract cases overlap for subprogram ABC";
|
|
|
709 -- Str1 : constant String :=
|
|
|
710 -- (if Flag_1 then
|
|
|
711 -- Str0 & "case guard at xxx evaluates to True"
|
|
|
712 -- else Str0);
|
|
|
713 -- StrN : constant String :=
|
|
|
714 -- (if Flag_N then
|
|
|
715 -- StrN-1 & "case guard at xxx evaluates to True"
|
|
|
716 -- else StrN-1);
|
|
|
717 -- begin
|
|
|
718 -- raise Assertion_Error with StrN;
|
|
|
719 -- end;
|
|
|
720 -- end if;
|
|
|
721
|
|
|
722 -- -- Evaluate all attribute 'Old prefixes found in the selected
|
|
|
723 -- -- consequence.
|
|
|
724
|
|
|
725 -- if Flag_1 then
|
|
|
726 -- Pref_1 := <prefix of 'Old found in Consequence_1>
|
|
|
727 -- . . .
|
|
|
728 -- elsif Flag_N then
|
|
|
729 -- Pref_M := <prefix of 'Old found in Consequence_N>
|
|
|
730 -- end if;
|
|
|
731
|
|
|
732 -- procedure _Postconditions is
|
|
|
733 -- begin
|
|
|
734 -- <postconditions (if any)>
|
|
|
735
|
|
|
736 -- if Flag_1 and then not Consequence_1 then
|
|
|
737 -- raise Assertion_Error with "failed contract case at xxx";
|
|
|
738 -- end if;
|
|
|
739 -- . . .
|
|
|
740 -- if Flag_N[+1] and then not Consequence_N[+1] then
|
|
|
741 -- raise Assertion_Error with "failed contract case at xxx";
|
|
|
742 -- end if;
|
|
|
743 -- end _Postconditions;
|
|
|
744 -- begin
|
|
|
745 -- . . .
|
|
|
746 -- end S;
|
|
|
747
|
|
|
748 procedure Expand_Pragma_Contract_Cases
|
|
|
749 (CCs : Node_Id;
|
|
|
750 Subp_Id : Entity_Id;
|
|
|
751 Decls : List_Id;
|
|
|
752 Stmts : in out List_Id)
|
|
|
753 is
|
|
|
754 Loc : constant Source_Ptr := Sloc (CCs);
|
|
|
755
|
|
|
756 procedure Case_Guard_Error
|
|
|
757 (Decls : List_Id;
|
|
|
758 Flag : Entity_Id;
|
|
|
759 Error_Loc : Source_Ptr;
|
|
|
760 Msg : in out Entity_Id);
|
|
|
761 -- Given a declarative list Decls, status flag Flag, the location of the
|
|
|
762 -- error and a string Msg, construct the following check:
|
|
|
763 -- Msg : constant String :=
|
|
|
764 -- (if Flag then
|
|
|
765 -- Msg & "case guard at Error_Loc evaluates to True"
|
|
|
766 -- else Msg);
|
|
|
767 -- The resulting code is added to Decls
|
|
|
768
|
|
|
769 procedure Consequence_Error
|
|
|
770 (Checks : in out Node_Id;
|
|
|
771 Flag : Entity_Id;
|
|
|
772 Conseq : Node_Id);
|
|
|
773 -- Given an if statement Checks, status flag Flag and a consequence
|
|
|
774 -- Conseq, construct the following check:
|
|
|
775 -- [els]if Flag and then not Conseq then
|
|
|
776 -- raise Assertion_Error
|
|
|
777 -- with "failed contract case at Sloc (Conseq)";
|
|
|
778 -- [end if;]
|
|
|
779 -- The resulting code is added to Checks
|
|
|
780
|
|
|
781 function Declaration_Of (Id : Entity_Id) return Node_Id;
|
|
|
782 -- Given the entity Id of a boolean flag, generate:
|
|
|
783 -- Id : Boolean := False;
|
|
|
784
|
|
|
785 procedure Expand_Attributes_In_Consequence
|
|
|
786 (Decls : List_Id;
|
|
|
787 Evals : in out Node_Id;
|
|
|
788 Flag : Entity_Id;
|
|
|
789 Conseq : Node_Id);
|
|
|
790 -- Perform specialized expansion of all attribute 'Old references found
|
|
|
791 -- in consequence Conseq such that at runtime only prefixes coming from
|
|
|
792 -- the selected consequence are evaluated. Similarly expand attribute
|
|
|
793 -- 'Result references by replacing them with identifier _result which
|
|
|
794 -- resolves to the sole formal parameter of procedure _Postconditions.
|
|
|
795 -- Any temporaries generated in the process are added to declarations
|
|
|
796 -- Decls. Evals is a complex if statement tasked with the evaluation of
|
|
|
797 -- all prefixes coming from a single selected consequence. Flag is the
|
|
|
798 -- corresponding case guard flag. Conseq is the consequence expression.
|
|
|
799
|
|
|
800 function Increment (Id : Entity_Id) return Node_Id;
|
|
|
801 -- Given the entity Id of a numerical variable, generate:
|
|
|
802 -- Id := Id + 1;
|
|
|
803
|
|
|
804 function Set (Id : Entity_Id) return Node_Id;
|
|
|
805 -- Given the entity Id of a boolean variable, generate:
|
|
|
806 -- Id := True;
|
|
|
807
|
|
|
808 ----------------------
|
|
|
809 -- Case_Guard_Error --
|
|
|
810 ----------------------
|
|
|
811
|
|
|
812 procedure Case_Guard_Error
|
|
|
813 (Decls : List_Id;
|
|
|
814 Flag : Entity_Id;
|
|
|
815 Error_Loc : Source_Ptr;
|
|
|
816 Msg : in out Entity_Id)
|
|
|
817 is
|
|
|
818 New_Line : constant Character := Character'Val (10);
|
|
|
819 New_Msg : constant Entity_Id := Make_Temporary (Loc, 'S');
|
|
|
820
|
|
|
821 begin
|
|
|
822 Start_String;
|
|
|
823 Store_String_Char (New_Line);
|
|
|
824 Store_String_Chars (" case guard at ");
|
|
|
825 Store_String_Chars (Build_Location_String (Error_Loc));
|
|
|
826 Store_String_Chars (" evaluates to True");
|
|
|
827
|
|
|
828 -- Generate:
|
|
|
829 -- New_Msg : constant String :=
|
|
|
830 -- (if Flag then
|
|
|
831 -- Msg & "case guard at Error_Loc evaluates to True"
|
|
|
832 -- else Msg);
|
|
|
833
|
|
|
834 Append_To (Decls,
|
|
|
835 Make_Object_Declaration (Loc,
|
|
|
836 Defining_Identifier => New_Msg,
|
|
|
837 Constant_Present => True,
|
|
|
838 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
|
|
|
839 Expression =>
|
|
|
840 Make_If_Expression (Loc,
|
|
|
841 Expressions => New_List (
|
|
|
842 New_Occurrence_Of (Flag, Loc),
|
|
|
843
|
|
|
844 Make_Op_Concat (Loc,
|
|
|
845 Left_Opnd => New_Occurrence_Of (Msg, Loc),
|
|
|
846 Right_Opnd => Make_String_Literal (Loc, End_String)),
|
|
|
847
|
|
|
848 New_Occurrence_Of (Msg, Loc)))));
|
|
|
849
|
|
|
850 Msg := New_Msg;
|
|
|
851 end Case_Guard_Error;
|
|
|
852
|
|
|
853 -----------------------
|
|
|
854 -- Consequence_Error --
|
|
|
855 -----------------------
|
|
|
856
|
|
|
857 procedure Consequence_Error
|
|
|
858 (Checks : in out Node_Id;
|
|
|
859 Flag : Entity_Id;
|
|
|
860 Conseq : Node_Id)
|
|
|
861 is
|
|
|
862 Cond : Node_Id;
|
|
|
863 Error : Node_Id;
|
|
|
864
|
|
|
865 begin
|
|
|
866 -- Generate:
|
|
|
867 -- Flag and then not Conseq
|
|
|
868
|
|
|
869 Cond :=
|
|
|
870 Make_And_Then (Loc,
|
|
|
871 Left_Opnd => New_Occurrence_Of (Flag, Loc),
|
|
|
872 Right_Opnd =>
|
|
|
873 Make_Op_Not (Loc,
|
|
|
874 Right_Opnd => Relocate_Node (Conseq)));
|
|
|
875
|
|
|
876 -- Generate:
|
|
|
877 -- raise Assertion_Error
|
|
|
878 -- with "failed contract case at Sloc (Conseq)";
|
|
|
879
|
|
|
880 Start_String;
|
|
|
881 Store_String_Chars ("failed contract case at ");
|
|
|
882 Store_String_Chars (Build_Location_String (Sloc (Conseq)));
|
|
|
883
|
|
|
884 Error :=
|
|
|
885 Make_Procedure_Call_Statement (Loc,
|
|
|
886 Name =>
|
|
|
887 New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc),
|
|
|
888 Parameter_Associations => New_List (
|
|
|
889 Make_String_Literal (Loc, End_String)));
|
|
|
890
|
|
|
891 if No (Checks) then
|
|
|
892 Checks :=
|
|
|
893 Make_Implicit_If_Statement (CCs,
|
|
|
894 Condition => Cond,
|
|
|
895 Then_Statements => New_List (Error));
|
|
|
896
|
|
|
897 else
|
|
|
898 if No (Elsif_Parts (Checks)) then
|
|
|
899 Set_Elsif_Parts (Checks, New_List);
|
|
|
900 end if;
|
|
|
901
|
|
|
902 Append_To (Elsif_Parts (Checks),
|
|
|
903 Make_Elsif_Part (Loc,
|
|
|
904 Condition => Cond,
|
|
|
905 Then_Statements => New_List (Error)));
|
|
|
906 end if;
|
|
|
907 end Consequence_Error;
|
|
|
908
|
|
|
909 --------------------
|
|
|
910 -- Declaration_Of --
|
|
|
911 --------------------
|
|
|
912
|
|
|
913 function Declaration_Of (Id : Entity_Id) return Node_Id is
|
|
|
914 begin
|
|
|
915 return
|
|
|
916 Make_Object_Declaration (Loc,
|
|
|
917 Defining_Identifier => Id,
|
|
|
918 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
|
|
|
919 Expression => New_Occurrence_Of (Standard_False, Loc));
|
|
|
920 end Declaration_Of;
|
|
|
921
|
|
|
922 --------------------------------------
|
|
|
923 -- Expand_Attributes_In_Consequence --
|
|
|
924 --------------------------------------
|
|
|
925
|
|
|
926 procedure Expand_Attributes_In_Consequence
|
|
|
927 (Decls : List_Id;
|
|
|
928 Evals : in out Node_Id;
|
|
|
929 Flag : Entity_Id;
|
|
|
930 Conseq : Node_Id)
|
|
|
931 is
|
|
|
932 Eval_Stmts : List_Id := No_List;
|
|
|
933 -- The evaluation sequence expressed as assignment statements of all
|
|
|
934 -- prefixes of attribute 'Old found in the current consequence.
|
|
|
935
|
|
|
936 function Expand_Attributes (N : Node_Id) return Traverse_Result;
|
|
|
937 -- Determine whether an arbitrary node denotes attribute 'Old or
|
|
|
938 -- 'Result and if it does, perform all expansion-related actions.
|
|
|
939
|
|
|
940 -----------------------
|
|
|
941 -- Expand_Attributes --
|
|
|
942 -----------------------
|
|
|
943
|
|
|
944 function Expand_Attributes (N : Node_Id) return Traverse_Result is
|
|
|
945 Decl : Node_Id;
|
|
|
946 Pref : Node_Id;
|
|
|
947 Temp : Entity_Id;
|
|
|
948
|
|
|
949 begin
|
|
|
950 -- Attribute 'Old
|
|
|
951
|
|
|
952 if Nkind (N) = N_Attribute_Reference
|
|
|
953 and then Attribute_Name (N) = Name_Old
|
|
|
954 then
|
|
|
955 Pref := Prefix (N);
|
|
|
956 Temp := Make_Temporary (Loc, 'T', Pref);
|
|
|
957 Set_Etype (Temp, Etype (Pref));
|
|
|
958
|
|
|
959 -- Generate a temporary to capture the value of the prefix:
|
|
|
960 -- Temp : <Pref type>;
|
|
|
961
|
|
|
962 Decl :=
|
|
|
963 Make_Object_Declaration (Loc,
|
|
|
964 Defining_Identifier => Temp,
|
|
|
965 Object_Definition =>
|
|
|
966 New_Occurrence_Of (Etype (Pref), Loc));
|
|
|
967
|
|
|
968 -- Place that temporary at the beginning of declarations, to
|
|
|
969 -- prevent anomalies in the GNATprove flow-analysis pass in
|
|
|
970 -- the precondition procedure that follows.
|
|
|
971
|
|
|
972 Prepend_To (Decls, Decl);
|
|
|
973
|
|
|
974 -- If the type is unconstrained, the prefix provides its
|
|
|
975 -- value and constraint, so add it to declaration.
|
|
|
976
|
|
|
977 if not Is_Constrained (Etype (Pref))
|
|
|
978 and then Is_Entity_Name (Pref)
|
|
|
979 then
|
|
|
980 Set_Expression (Decl, Pref);
|
|
|
981 Analyze (Decl);
|
|
|
982
|
|
|
983 -- Otherwise add an assignment statement to temporary using
|
|
|
984 -- prefix as RHS.
|
|
|
985
|
|
|
986 else
|
|
|
987 Analyze (Decl);
|
|
|
988
|
|
|
989 if No (Eval_Stmts) then
|
|
|
990 Eval_Stmts := New_List;
|
|
|
991 end if;
|
|
|
992
|
|
|
993 Append_To (Eval_Stmts,
|
|
|
994 Make_Assignment_Statement (Loc,
|
|
|
995 Name => New_Occurrence_Of (Temp, Loc),
|
|
|
996 Expression => Pref));
|
|
|
997
|
|
|
998 end if;
|
|
|
999
|
|
|
1000 -- Ensure that the prefix is valid
|
|
|
1001
|
|
|
1002 if Validity_Checks_On and then Validity_Check_Operands then
|
|
|
1003 Ensure_Valid (Pref);
|
|
|
1004 end if;
|
|
|
1005
|
|
|
1006 -- Replace the original attribute 'Old by a reference to the
|
|
|
1007 -- generated temporary.
|
|
|
1008
|
|
|
1009 Rewrite (N, New_Occurrence_Of (Temp, Loc));
|
|
|
1010
|
|
|
1011 -- Attribute 'Result
|
|
|
1012
|
|
|
1013 elsif Is_Attribute_Result (N) then
|
|
|
1014 Rewrite (N, Make_Identifier (Loc, Name_uResult));
|
|
|
1015 end if;
|
|
|
1016
|
|
|
1017 return OK;
|
|
|
1018 end Expand_Attributes;
|
|
|
1019
|
|
|
1020 procedure Expand_Attributes_In is
|
|
|
1021 new Traverse_Proc (Expand_Attributes);
|
|
|
1022
|
|
|
1023 -- Start of processing for Expand_Attributes_In_Consequence
|
|
|
1024
|
|
|
1025 begin
|
|
|
1026 -- Inspect the consequence and expand any attribute 'Old and 'Result
|
|
|
1027 -- references found within.
|
|
|
1028
|
|
|
1029 Expand_Attributes_In (Conseq);
|
|
|
1030
|
|
|
1031 -- The consequence does not contain any attribute 'Old references
|
|
|
1032
|
|
|
1033 if No (Eval_Stmts) then
|
|
|
1034 return;
|
|
|
1035 end if;
|
|
|
1036
|
|
|
1037 -- Augment the machinery to trigger the evaluation of all prefixes
|
|
|
1038 -- found in the step above. If Eval is empty, then this is the first
|
|
|
1039 -- consequence to yield expansion of 'Old. Generate:
|
|
|
1040
|
|
|
1041 -- if Flag then
|
|
|
1042 -- <evaluation statements>
|
|
|
1043 -- end if;
|
|
|
1044
|
|
|
1045 if No (Evals) then
|
|
|
1046 Evals :=
|
|
|
1047 Make_Implicit_If_Statement (CCs,
|
|
|
1048 Condition => New_Occurrence_Of (Flag, Loc),
|
|
|
1049 Then_Statements => Eval_Stmts);
|
|
|
1050
|
|
|
1051 -- Otherwise generate:
|
|
|
1052 -- elsif Flag then
|
|
|
1053 -- <evaluation statements>
|
|
|
1054 -- end if;
|
|
|
1055
|
|
|
1056 else
|
|
|
1057 if No (Elsif_Parts (Evals)) then
|
|
|
1058 Set_Elsif_Parts (Evals, New_List);
|
|
|
1059 end if;
|
|
|
1060
|
|
|
1061 Append_To (Elsif_Parts (Evals),
|
|
|
1062 Make_Elsif_Part (Loc,
|
|
|
1063 Condition => New_Occurrence_Of (Flag, Loc),
|
|
|
1064 Then_Statements => Eval_Stmts));
|
|
|
1065 end if;
|
|
|
1066 end Expand_Attributes_In_Consequence;
|
|
|
1067
|
|
|
1068 ---------------
|
|
|
1069 -- Increment --
|
|
|
1070 ---------------
|
|
|
1071
|
|
|
1072 function Increment (Id : Entity_Id) return Node_Id is
|
|
|
1073 begin
|
|
|
1074 return
|
|
|
1075 Make_Assignment_Statement (Loc,
|
|
|
1076 Name => New_Occurrence_Of (Id, Loc),
|
|
|
1077 Expression =>
|
|
|
1078 Make_Op_Add (Loc,
|
|
|
1079 Left_Opnd => New_Occurrence_Of (Id, Loc),
|
|
|
1080 Right_Opnd => Make_Integer_Literal (Loc, 1)));
|
|
|
1081 end Increment;
|
|
|
1082
|
|
|
1083 ---------
|
|
|
1084 -- Set --
|
|
|
1085 ---------
|
|
|
1086
|
|
|
1087 function Set (Id : Entity_Id) return Node_Id is
|
|
|
1088 begin
|
|
|
1089 return
|
|
|
1090 Make_Assignment_Statement (Loc,
|
|
|
1091 Name => New_Occurrence_Of (Id, Loc),
|
|
|
1092 Expression => New_Occurrence_Of (Standard_True, Loc));
|
|
|
1093 end Set;
|
|
|
1094
|
|
|
1095 -- Local variables
|
|
|
1096
|
|
|
1097 Aggr : constant Node_Id :=
|
|
|
1098 Expression (First (Pragma_Argument_Associations (CCs)));
|
|
|
1099
|
|
|
1100 Case_Guard : Node_Id;
|
|
|
1101 CG_Checks : Node_Id;
|
|
|
1102 CG_Stmts : List_Id;
|
|
|
1103 Conseq : Node_Id;
|
|
|
1104 Conseq_Checks : Node_Id := Empty;
|
|
|
1105 Count : Entity_Id;
|
|
|
1106 Count_Decl : Node_Id;
|
|
131
|
1107 Error_Decls : List_Id := No_List; -- init to avoid warning
|
|
111
|
1108 Flag : Entity_Id;
|
|
|
1109 Flag_Decl : Node_Id;
|
|
|
1110 If_Stmt : Node_Id;
|
|
|
1111 Msg_Str : Entity_Id := Empty;
|
|
|
1112 Multiple_PCs : Boolean;
|
|
|
1113 Old_Evals : Node_Id := Empty;
|
|
|
1114 Others_Decl : Node_Id;
|
|
|
1115 Others_Flag : Entity_Id := Empty;
|
|
|
1116 Post_Case : Node_Id;
|
|
|
1117
|
|
|
1118 -- Start of processing for Expand_Pragma_Contract_Cases
|
|
|
1119
|
|
|
1120 begin
|
|
|
1121 -- Do nothing if pragma is not enabled. If pragma is disabled, it has
|
|
|
1122 -- already been rewritten as a Null statement.
|
|
|
1123
|
|
|
1124 if Is_Ignored (CCs) then
|
|
|
1125 return;
|
|
|
1126
|
|
|
1127 -- Guard against malformed contract cases
|
|
|
1128
|
|
|
1129 elsif Nkind (Aggr) /= N_Aggregate then
|
|
|
1130 return;
|
|
|
1131 end if;
|
|
|
1132
|
|
|
1133 -- The expansion of contract cases is quite distributed as it produces
|
|
|
1134 -- various statements to evaluate the case guards and consequences. To
|
|
|
1135 -- preserve the original context, set the Is_Assertion_Expr flag. This
|
|
|
1136 -- aids the Ghost legality checks when verifying the placement of a
|
|
|
1137 -- reference to a Ghost entity.
|
|
|
1138
|
|
|
1139 In_Assertion_Expr := In_Assertion_Expr + 1;
|
|
|
1140
|
|
|
1141 Multiple_PCs := List_Length (Component_Associations (Aggr)) > 1;
|
|
|
1142
|
|
|
1143 -- Create the counter which tracks the number of case guards that
|
|
|
1144 -- evaluate to True.
|
|
|
1145
|
|
|
1146 -- Count : Natural := 0;
|
|
|
1147
|
|
|
1148 Count := Make_Temporary (Loc, 'C');
|
|
|
1149 Count_Decl :=
|
|
|
1150 Make_Object_Declaration (Loc,
|
|
|
1151 Defining_Identifier => Count,
|
|
|
1152 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc),
|
|
|
1153 Expression => Make_Integer_Literal (Loc, 0));
|
|
|
1154
|
|
|
1155 Prepend_To (Decls, Count_Decl);
|
|
|
1156 Analyze (Count_Decl);
|
|
|
1157
|
|
|
1158 -- Create the base error message for multiple overlapping case guards
|
|
|
1159
|
|
|
1160 -- Msg_Str : constant String :=
|
|
|
1161 -- "contract cases overlap for subprogram Subp_Id";
|
|
|
1162
|
|
|
1163 if Multiple_PCs then
|
|
|
1164 Msg_Str := Make_Temporary (Loc, 'S');
|
|
|
1165
|
|
|
1166 Start_String;
|
|
|
1167 Store_String_Chars ("contract cases overlap for subprogram ");
|
|
|
1168 Store_String_Chars (Get_Name_String (Chars (Subp_Id)));
|
|
|
1169
|
|
|
1170 Error_Decls := New_List (
|
|
|
1171 Make_Object_Declaration (Loc,
|
|
|
1172 Defining_Identifier => Msg_Str,
|
|
|
1173 Constant_Present => True,
|
|
|
1174 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
|
|
|
1175 Expression => Make_String_Literal (Loc, End_String)));
|
|
|
1176 end if;
|
|
|
1177
|
|
|
1178 -- Process individual post cases
|
|
|
1179
|
|
|
1180 Post_Case := First (Component_Associations (Aggr));
|
|
|
1181 while Present (Post_Case) loop
|
|
|
1182 Case_Guard := First (Choices (Post_Case));
|
|
|
1183 Conseq := Expression (Post_Case);
|
|
|
1184
|
|
|
1185 -- The "others" choice requires special processing
|
|
|
1186
|
|
|
1187 if Nkind (Case_Guard) = N_Others_Choice then
|
|
|
1188 Others_Flag := Make_Temporary (Loc, 'F');
|
|
|
1189 Others_Decl := Declaration_Of (Others_Flag);
|
|
|
1190
|
|
|
1191 Prepend_To (Decls, Others_Decl);
|
|
|
1192 Analyze (Others_Decl);
|
|
|
1193
|
|
|
1194 -- Check possible overlap between a case guard and "others"
|
|
|
1195
|
|
|
1196 if Multiple_PCs and Exception_Extra_Info then
|
|
|
1197 Case_Guard_Error
|
|
|
1198 (Decls => Error_Decls,
|
|
|
1199 Flag => Others_Flag,
|
|
|
1200 Error_Loc => Sloc (Case_Guard),
|
|
|
1201 Msg => Msg_Str);
|
|
|
1202 end if;
|
|
|
1203
|
|
|
1204 -- Inspect the consequence and perform special expansion of any
|
|
|
1205 -- attribute 'Old and 'Result references found within.
|
|
|
1206
|
|
|
1207 Expand_Attributes_In_Consequence
|
|
|
1208 (Decls => Decls,
|
|
|
1209 Evals => Old_Evals,
|
|
|
1210 Flag => Others_Flag,
|
|
|
1211 Conseq => Conseq);
|
|
|
1212
|
|
|
1213 -- Check the corresponding consequence of "others"
|
|
|
1214
|
|
|
1215 Consequence_Error
|
|
|
1216 (Checks => Conseq_Checks,
|
|
|
1217 Flag => Others_Flag,
|
|
|
1218 Conseq => Conseq);
|
|
|
1219
|
|
|
1220 -- Regular post case
|
|
|
1221
|
|
|
1222 else
|
|
|
1223 -- Create the flag which tracks the state of its associated case
|
|
|
1224 -- guard.
|
|
|
1225
|
|
|
1226 Flag := Make_Temporary (Loc, 'F');
|
|
|
1227 Flag_Decl := Declaration_Of (Flag);
|
|
|
1228
|
|
|
1229 Prepend_To (Decls, Flag_Decl);
|
|
|
1230 Analyze (Flag_Decl);
|
|
|
1231
|
|
|
1232 -- The flag is set when the case guard is evaluated to True
|
|
|
1233 -- if Case_Guard then
|
|
|
1234 -- Flag := True;
|
|
|
1235 -- Count := Count + 1;
|
|
|
1236 -- end if;
|
|
|
1237
|
|
|
1238 If_Stmt :=
|
|
|
1239 Make_Implicit_If_Statement (CCs,
|
|
|
1240 Condition => Relocate_Node (Case_Guard),
|
|
|
1241 Then_Statements => New_List (
|
|
|
1242 Set (Flag),
|
|
|
1243 Increment (Count)));
|
|
|
1244
|
|
|
1245 Append_To (Decls, If_Stmt);
|
|
|
1246 Analyze (If_Stmt);
|
|
|
1247
|
|
|
1248 -- Check whether this case guard overlaps with another one
|
|
|
1249
|
|
|
1250 if Multiple_PCs and Exception_Extra_Info then
|
|
|
1251 Case_Guard_Error
|
|
|
1252 (Decls => Error_Decls,
|
|
|
1253 Flag => Flag,
|
|
|
1254 Error_Loc => Sloc (Case_Guard),
|
|
|
1255 Msg => Msg_Str);
|
|
|
1256 end if;
|
|
|
1257
|
|
|
1258 -- Inspect the consequence and perform special expansion of any
|
|
|
1259 -- attribute 'Old and 'Result references found within.
|
|
|
1260
|
|
|
1261 Expand_Attributes_In_Consequence
|
|
|
1262 (Decls => Decls,
|
|
|
1263 Evals => Old_Evals,
|
|
|
1264 Flag => Flag,
|
|
|
1265 Conseq => Conseq);
|
|
|
1266
|
|
|
1267 -- The corresponding consequence of the case guard which evaluated
|
|
|
1268 -- to True must hold on exit from the subprogram.
|
|
|
1269
|
|
|
1270 Consequence_Error
|
|
|
1271 (Checks => Conseq_Checks,
|
|
|
1272 Flag => Flag,
|
|
|
1273 Conseq => Conseq);
|
|
|
1274 end if;
|
|
|
1275
|
|
|
1276 Next (Post_Case);
|
|
|
1277 end loop;
|
|
|
1278
|
|
|
1279 -- Raise Assertion_Error when none of the case guards evaluate to True.
|
|
|
1280 -- The only exception is when we have "others", in which case there is
|
|
|
1281 -- no error because "others" acts as a default True.
|
|
|
1282
|
|
|
1283 -- Generate:
|
|
|
1284 -- Flag := True;
|
|
|
1285
|
|
|
1286 if Present (Others_Flag) then
|
|
|
1287 CG_Stmts := New_List (Set (Others_Flag));
|
|
|
1288
|
|
|
1289 -- Generate:
|
|
|
1290 -- raise Assertion_Error with "xxx contract cases incomplete";
|
|
|
1291
|
|
|
1292 else
|
|
|
1293 Start_String;
|
|
|
1294 Store_String_Chars (Build_Location_String (Loc));
|
|
|
1295 Store_String_Chars (" contract cases incomplete");
|
|
|
1296
|
|
|
1297 CG_Stmts := New_List (
|
|
|
1298 Make_Procedure_Call_Statement (Loc,
|
|
|
1299 Name =>
|
|
|
1300 New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc),
|
|
|
1301 Parameter_Associations => New_List (
|
|
|
1302 Make_String_Literal (Loc, End_String))));
|
|
|
1303 end if;
|
|
|
1304
|
|
|
1305 CG_Checks :=
|
|
|
1306 Make_Implicit_If_Statement (CCs,
|
|
|
1307 Condition =>
|
|
|
1308 Make_Op_Eq (Loc,
|
|
|
1309 Left_Opnd => New_Occurrence_Of (Count, Loc),
|
|
|
1310 Right_Opnd => Make_Integer_Literal (Loc, 0)),
|
|
|
1311 Then_Statements => CG_Stmts);
|
|
|
1312
|
|
|
1313 -- Detect a possible failure due to several case guards evaluating to
|
|
|
1314 -- True.
|
|
|
1315
|
|
|
1316 -- Generate:
|
|
|
1317 -- elsif Count > 0 then
|
|
|
1318 -- declare
|
|
|
1319 -- <Error_Decls>
|
|
|
1320 -- begin
|
|
|
1321 -- raise Assertion_Error with <Msg_Str>;
|
|
|
1322 -- end if;
|
|
|
1323
|
|
|
1324 if Multiple_PCs then
|
|
|
1325 Set_Elsif_Parts (CG_Checks, New_List (
|
|
|
1326 Make_Elsif_Part (Loc,
|
|
|
1327 Condition =>
|
|
|
1328 Make_Op_Gt (Loc,
|
|
|
1329 Left_Opnd => New_Occurrence_Of (Count, Loc),
|
|
|
1330 Right_Opnd => Make_Integer_Literal (Loc, 1)),
|
|
|
1331
|
|
|
1332 Then_Statements => New_List (
|
|
|
1333 Make_Block_Statement (Loc,
|
|
|
1334 Declarations => Error_Decls,
|
|
|
1335 Handled_Statement_Sequence =>
|
|
|
1336 Make_Handled_Sequence_Of_Statements (Loc,
|
|
|
1337 Statements => New_List (
|
|
|
1338 Make_Procedure_Call_Statement (Loc,
|
|
|
1339 Name =>
|
|
|
1340 New_Occurrence_Of
|
|
|
1341 (RTE (RE_Raise_Assert_Failure), Loc),
|
|
|
1342 Parameter_Associations => New_List (
|
|
|
1343 New_Occurrence_Of (Msg_Str, Loc))))))))));
|
|
|
1344 end if;
|
|
|
1345
|
|
|
1346 Append_To (Decls, CG_Checks);
|
|
|
1347 Analyze (CG_Checks);
|
|
|
1348
|
|
|
1349 -- Once all case guards are evaluated and checked, evaluate any prefixes
|
|
|
1350 -- of attribute 'Old founds in the selected consequence.
|
|
|
1351
|
|
|
1352 if Present (Old_Evals) then
|
|
|
1353 Append_To (Decls, Old_Evals);
|
|
|
1354 Analyze (Old_Evals);
|
|
|
1355 end if;
|
|
|
1356
|
|
|
1357 -- Raise Assertion_Error when the corresponding consequence of a case
|
|
|
1358 -- guard that evaluated to True fails.
|
|
|
1359
|
|
|
1360 if No (Stmts) then
|
|
|
1361 Stmts := New_List;
|
|
|
1362 end if;
|
|
|
1363
|
|
|
1364 Append_To (Stmts, Conseq_Checks);
|
|
|
1365
|
|
|
1366 In_Assertion_Expr := In_Assertion_Expr - 1;
|
|
|
1367 end Expand_Pragma_Contract_Cases;
|
|
|
1368
|
|
|
1369 ---------------------------------------
|
|
|
1370 -- Expand_Pragma_Import_Or_Interface --
|
|
|
1371 ---------------------------------------
|
|
|
1372
|
|
|
1373 procedure Expand_Pragma_Import_Or_Interface (N : Node_Id) is
|
|
|
1374 Def_Id : Entity_Id;
|
|
|
1375
|
|
|
1376 begin
|
|
|
1377 -- In Relaxed_RM_Semantics, support old Ada 83 style:
|
|
|
1378 -- pragma Import (Entity, "external name");
|
|
|
1379
|
|
|
1380 if Relaxed_RM_Semantics
|
|
|
1381 and then List_Length (Pragma_Argument_Associations (N)) = 2
|
|
|
1382 and then Pragma_Name (N) = Name_Import
|
|
|
1383 and then Nkind (Arg2 (N)) = N_String_Literal
|
|
|
1384 then
|
|
|
1385 Def_Id := Entity (Arg1 (N));
|
|
|
1386 else
|
|
|
1387 Def_Id := Entity (Arg2 (N));
|
|
|
1388 end if;
|
|
|
1389
|
|
|
1390 -- Variable case (we have to undo any initialization already done)
|
|
|
1391
|
|
|
1392 if Ekind (Def_Id) = E_Variable then
|
|
|
1393 Undo_Initialization (Def_Id, N);
|
|
|
1394
|
|
|
1395 -- Case of exception with convention C++
|
|
|
1396
|
|
|
1397 elsif Ekind (Def_Id) = E_Exception
|
|
|
1398 and then Convention (Def_Id) = Convention_CPP
|
|
|
1399 then
|
|
|
1400 -- Import a C++ convention
|
|
|
1401
|
|
|
1402 declare
|
|
|
1403 Loc : constant Source_Ptr := Sloc (N);
|
|
|
1404 Rtti_Name : constant Node_Id := Arg3 (N);
|
|
|
1405 Dum : constant Entity_Id := Make_Temporary (Loc, 'D');
|
|
|
1406 Exdata : List_Id;
|
|
|
1407 Lang_Char : Node_Id;
|
|
|
1408 Foreign_Data : Node_Id;
|
|
|
1409
|
|
|
1410 begin
|
|
|
1411 Exdata := Component_Associations (Expression (Parent (Def_Id)));
|
|
|
1412
|
|
|
1413 Lang_Char := Next (First (Exdata));
|
|
|
1414
|
|
|
1415 -- Change the one-character language designator to 'C'
|
|
|
1416
|
|
|
1417 Rewrite (Expression (Lang_Char),
|
|
|
1418 Make_Character_Literal (Loc,
|
|
|
1419 Chars => Name_uC,
|
|
|
1420 Char_Literal_Value => UI_From_Int (Character'Pos ('C'))));
|
|
|
1421 Analyze (Expression (Lang_Char));
|
|
|
1422
|
|
|
1423 -- Change the value of Foreign_Data
|
|
|
1424
|
|
|
1425 Foreign_Data := Next (Next (Next (Next (Lang_Char))));
|
|
|
1426
|
|
|
1427 Insert_Actions (Def_Id, New_List (
|
|
|
1428 Make_Object_Declaration (Loc,
|
|
|
1429 Defining_Identifier => Dum,
|
|
|
1430 Object_Definition =>
|
|
|
1431 New_Occurrence_Of (Standard_Character, Loc)),
|
|
|
1432
|
|
|
1433 Make_Pragma (Loc,
|
|
|
1434 Chars => Name_Import,
|
|
|
1435 Pragma_Argument_Associations => New_List (
|
|
|
1436 Make_Pragma_Argument_Association (Loc,
|
|
|
1437 Expression => Make_Identifier (Loc, Name_Ada)),
|
|
|
1438
|
|
|
1439 Make_Pragma_Argument_Association (Loc,
|
|
|
1440 Expression => Make_Identifier (Loc, Chars (Dum))),
|
|
|
1441
|
|
|
1442 Make_Pragma_Argument_Association (Loc,
|
|
|
1443 Chars => Name_External_Name,
|
|
|
1444 Expression => Relocate_Node (Rtti_Name))))));
|
|
|
1445
|
|
|
1446 Rewrite (Expression (Foreign_Data),
|
|
|
1447 Unchecked_Convert_To (Standard_A_Char,
|
|
|
1448 Make_Attribute_Reference (Loc,
|
|
|
1449 Prefix => Make_Identifier (Loc, Chars (Dum)),
|
|
|
1450 Attribute_Name => Name_Address)));
|
|
|
1451 Analyze (Expression (Foreign_Data));
|
|
|
1452 end;
|
|
|
1453
|
|
|
1454 -- No special expansion required for any other case
|
|
|
1455
|
|
|
1456 else
|
|
|
1457 null;
|
|
|
1458 end if;
|
|
|
1459 end Expand_Pragma_Import_Or_Interface;
|
|
|
1460
|
|
|
1461 -------------------------------------
|
|
|
1462 -- Expand_Pragma_Initial_Condition --
|
|
|
1463 -------------------------------------
|
|
|
1464
|
|
|
1465 procedure Expand_Pragma_Initial_Condition
|
|
|
1466 (Pack_Id : Entity_Id;
|
|
|
1467 N : Node_Id)
|
|
|
1468 is
|
|
|
1469 procedure Extract_Package_Body_Lists
|
|
|
1470 (Pack_Body : Node_Id;
|
|
|
1471 Body_List : out List_Id;
|
|
|
1472 Call_List : out List_Id;
|
|
|
1473 Spec_List : out List_Id);
|
|
|
1474 -- Obtain the various declarative and statement lists of package body
|
|
|
1475 -- Pack_Body needed to insert the initial condition procedure and the
|
|
|
1476 -- call to it. The lists are as follows:
|
|
|
1477 --
|
|
|
1478 -- * Body_List - used to insert the initial condition procedure body
|
|
|
1479 --
|
|
|
1480 -- * Call_List - used to insert the call to the initial condition
|
|
|
1481 -- procedure.
|
|
|
1482 --
|
|
|
1483 -- * Spec_List - used to insert the initial condition procedure spec
|
|
|
1484
|
|
|
1485 procedure Extract_Package_Declaration_Lists
|
|
|
1486 (Pack_Decl : Node_Id;
|
|
|
1487 Body_List : out List_Id;
|
|
|
1488 Call_List : out List_Id;
|
|
|
1489 Spec_List : out List_Id);
|
|
|
1490 -- Obtain the various declarative lists of package declaration Pack_Decl
|
|
|
1491 -- needed to insert the initial condition procedure and the call to it.
|
|
|
1492 -- The lists are as follows:
|
|
|
1493 --
|
|
|
1494 -- * Body_List - used to insert the initial condition procedure body
|
|
|
1495 --
|
|
|
1496 -- * Call_List - used to insert the call to the initial condition
|
|
|
1497 -- procedure.
|
|
|
1498 --
|
|
|
1499 -- * Spec_List - used to insert the initial condition procedure spec
|
|
|
1500
|
|
|
1501 --------------------------------
|
|
|
1502 -- Extract_Package_Body_Lists --
|
|
|
1503 --------------------------------
|
|
|
1504
|
|
|
1505 procedure Extract_Package_Body_Lists
|
|
|
1506 (Pack_Body : Node_Id;
|
|
|
1507 Body_List : out List_Id;
|
|
|
1508 Call_List : out List_Id;
|
|
|
1509 Spec_List : out List_Id)
|
|
|
1510 is
|
|
|
1511 Pack_Spec : constant Entity_Id := Corresponding_Spec (Pack_Body);
|
|
|
1512
|
|
|
1513 Dummy_1 : List_Id;
|
|
|
1514 Dummy_2 : List_Id;
|
|
|
1515 HSS : Node_Id;
|
|
|
1516
|
|
|
1517 begin
|
|
|
1518 pragma Assert (Present (Pack_Spec));
|
|
|
1519
|
|
|
1520 -- The different parts of the invariant procedure are inserted as
|
|
|
1521 -- follows:
|
|
|
1522
|
|
|
1523 -- package Pack is package body Pack is
|
|
|
1524 -- <IC spec> <IC body>
|
|
|
1525 -- private begin
|
|
|
1526 -- ... <IC call>
|
|
|
1527 -- end Pack; end Pack;
|
|
|
1528
|
|
|
1529 -- The initial condition procedure spec is inserted in the visible
|
|
|
1530 -- declaration of the corresponding package spec.
|
|
|
1531
|
|
|
1532 Extract_Package_Declaration_Lists
|
|
|
1533 (Pack_Decl => Unit_Declaration_Node (Pack_Spec),
|
|
|
1534 Body_List => Dummy_1,
|
|
|
1535 Call_List => Dummy_2,
|
|
|
1536 Spec_List => Spec_List);
|
|
|
1537
|
|
|
1538 -- The initial condition procedure body is added to the declarations
|
|
|
1539 -- of the package body.
|
|
|
1540
|
|
|
1541 Body_List := Declarations (Pack_Body);
|
|
|
1542
|
|
|
1543 if No (Body_List) then
|
|
|
1544 Body_List := New_List;
|
|
|
1545 Set_Declarations (Pack_Body, Body_List);
|
|
|
1546 end if;
|
|
|
1547
|
|
|
1548 -- The call to the initial condition procedure is inserted in the
|
|
|
1549 -- statements of the package body.
|
|
|
1550
|
|
|
1551 HSS := Handled_Statement_Sequence (Pack_Body);
|
|
|
1552
|
|
|
1553 if No (HSS) then
|
|
|
1554 HSS :=
|
|
|
1555 Make_Handled_Sequence_Of_Statements (Sloc (Pack_Body),
|
|
|
1556 Statements => New_List);
|
|
|
1557 Set_Handled_Statement_Sequence (Pack_Body, HSS);
|
|
|
1558 end if;
|
|
|
1559
|
|
|
1560 Call_List := Statements (HSS);
|
|
|
1561 end Extract_Package_Body_Lists;
|
|
|
1562
|
|
|
1563 ---------------------------------------
|
|
|
1564 -- Extract_Package_Declaration_Lists --
|
|
|
1565 ---------------------------------------
|
|
|
1566
|
|
|
1567 procedure Extract_Package_Declaration_Lists
|
|
|
1568 (Pack_Decl : Node_Id;
|
|
|
1569 Body_List : out List_Id;
|
|
|
1570 Call_List : out List_Id;
|
|
|
1571 Spec_List : out List_Id)
|
|
|
1572 is
|
|
|
1573 Pack_Spec : constant Node_Id := Specification (Pack_Decl);
|
|
|
1574
|
|
|
1575 begin
|
|
|
1576 -- The different parts of the invariant procedure are inserted as
|
|
|
1577 -- follows:
|
|
|
1578
|
|
|
1579 -- package Pack is
|
|
|
1580 -- <IC spec>
|
|
|
1581 -- <IC body>
|
|
|
1582 -- private
|
|
|
1583 -- <IC call>
|
|
|
1584 -- end Pack;
|
|
|
1585
|
|
|
1586 -- The initial condition procedure spec and body are inserted in the
|
|
|
1587 -- visible declarations of the package spec.
|
|
|
1588
|
|
|
1589 Body_List := Visible_Declarations (Pack_Spec);
|
|
|
1590
|
|
|
1591 if No (Body_List) then
|
|
|
1592 Body_List := New_List;
|
|
|
1593 Set_Visible_Declarations (Pack_Spec, Body_List);
|
|
|
1594 end if;
|
|
|
1595
|
|
|
1596 Spec_List := Body_List;
|
|
|
1597
|
|
|
1598 -- The call to the initial procedure is inserted in the private
|
|
|
1599 -- declarations of the package spec.
|
|
|
1600
|
|
|
1601 Call_List := Private_Declarations (Pack_Spec);
|
|
|
1602
|
|
|
1603 if No (Call_List) then
|
|
|
1604 Call_List := New_List;
|
|
|
1605 Set_Private_Declarations (Pack_Spec, Call_List);
|
|
|
1606 end if;
|
|
|
1607 end Extract_Package_Declaration_Lists;
|
|
|
1608
|
|
|
1609 -- Local variables
|
|
|
1610
|
|
|
1611 IC_Prag : constant Node_Id :=
|
|
|
1612 Get_Pragma (Pack_Id, Pragma_Initial_Condition);
|
|
|
1613
|
|
|
1614 Body_List : List_Id;
|
|
|
1615 Call : Node_Id;
|
|
|
1616 Call_List : List_Id;
|
|
|
1617 Call_Loc : Source_Ptr;
|
|
|
1618 Expr : Node_Id;
|
|
|
1619 Loc : Source_Ptr;
|
|
|
1620 Proc_Body : Node_Id;
|
|
|
1621 Proc_Body_Id : Entity_Id;
|
|
|
1622 Proc_Decl : Node_Id;
|
|
|
1623 Proc_Id : Entity_Id;
|
|
|
1624 Spec_List : List_Id;
|
|
|
1625
|
|
|
1626 -- Start of processing for Expand_Pragma_Initial_Condition
|
|
|
1627
|
|
|
1628 begin
|
|
|
1629 -- Nothing to do when the package is not subject to an Initial_Condition
|
|
|
1630 -- pragma.
|
|
|
1631
|
|
|
1632 if No (IC_Prag) then
|
|
|
1633 return;
|
|
|
1634 end if;
|
|
|
1635
|
|
|
1636 Expr := Get_Pragma_Arg (First (Pragma_Argument_Associations (IC_Prag)));
|
|
|
1637 Loc := Sloc (IC_Prag);
|
|
|
1638
|
|
145
|
1639 -- Nothing to do when the pragma is ignored because its semantics are
|
|
|
1640 -- suppressed.
|
|
|
1641
|
|
|
1642 if Is_Ignored (IC_Prag) then
|
|
|
1643 return;
|
|
|
1644
|
|
111
|
1645 -- Nothing to do when the pragma or its argument are illegal because
|
|
|
1646 -- there is no valid expression to check.
|
|
|
1647
|
|
145
|
1648 elsif Error_Posted (IC_Prag) or else Error_Posted (Expr) then
|
|
111
|
1649 return;
|
|
|
1650 end if;
|
|
|
1651
|
|
|
1652 -- Obtain the various lists of the context where the individual pieces
|
|
|
1653 -- of the initial condition procedure are to be inserted.
|
|
|
1654
|
|
|
1655 if Nkind (N) = N_Package_Body then
|
|
|
1656 Extract_Package_Body_Lists
|
|
|
1657 (Pack_Body => N,
|
|
|
1658 Body_List => Body_List,
|
|
|
1659 Call_List => Call_List,
|
|
|
1660 Spec_List => Spec_List);
|
|
|
1661
|
|
|
1662 elsif Nkind (N) = N_Package_Declaration then
|
|
|
1663 Extract_Package_Declaration_Lists
|
|
|
1664 (Pack_Decl => N,
|
|
|
1665 Body_List => Body_List,
|
|
|
1666 Call_List => Call_List,
|
|
|
1667 Spec_List => Spec_List);
|
|
|
1668
|
|
|
1669 -- This routine should not be used on anything other than packages
|
|
|
1670
|
|
|
1671 else
|
|
|
1672 pragma Assert (False);
|
|
|
1673 return;
|
|
|
1674 end if;
|
|
|
1675
|
|
|
1676 Proc_Id :=
|
|
|
1677 Make_Defining_Identifier (Loc,
|
|
|
1678 Chars => New_External_Name (Chars (Pack_Id), "Initial_Condition"));
|
|
|
1679
|
|
|
1680 Set_Ekind (Proc_Id, E_Procedure);
|
|
|
1681 Set_Is_Initial_Condition_Procedure (Proc_Id);
|
|
|
1682
|
|
|
1683 -- Generate:
|
|
|
1684 -- procedure <Pack_Id>Initial_Condition;
|
|
|
1685
|
|
|
1686 Proc_Decl :=
|
|
|
1687 Make_Subprogram_Declaration (Loc,
|
|
|
1688 Make_Procedure_Specification (Loc,
|
|
|
1689 Defining_Unit_Name => Proc_Id));
|
|
|
1690
|
|
|
1691 Append_To (Spec_List, Proc_Decl);
|
|
|
1692
|
|
|
1693 -- The initial condition procedure requires debug info when initial
|
|
|
1694 -- condition is subject to Source Coverage Obligations.
|
|
|
1695
|
|
|
1696 if Generate_SCO then
|
|
145
|
1697 Set_Debug_Info_Needed (Proc_Id);
|
|
111
|
1698 end if;
|
|
|
1699
|
|
|
1700 -- Generate:
|
|
|
1701 -- procedure <Pack_Id>Initial_Condition is
|
|
|
1702 -- begin
|
|
|
1703 -- pragma Check (Initial_Condition, <Expr>);
|
|
|
1704 -- end <Pack_Id>Initial_Condition;
|
|
|
1705
|
|
|
1706 Proc_Body :=
|
|
|
1707 Make_Subprogram_Body (Loc,
|
|
|
1708 Specification =>
|
|
|
1709 Copy_Subprogram_Spec (Specification (Proc_Decl)),
|
|
|
1710 Declarations => Empty_List,
|
|
|
1711 Handled_Statement_Sequence =>
|
|
|
1712 Make_Handled_Sequence_Of_Statements (Loc,
|
|
|
1713 Statements => New_List (
|
|
|
1714 Make_Pragma (Loc,
|
|
|
1715 Chars => Name_Check,
|
|
|
1716 Pragma_Argument_Associations => New_List (
|
|
|
1717 Make_Pragma_Argument_Association (Loc,
|
|
|
1718 Expression =>
|
|
|
1719 Make_Identifier (Loc, Name_Initial_Condition)),
|
|
|
1720 Make_Pragma_Argument_Association (Loc,
|
|
|
1721 Expression => New_Copy_Tree (Expr)))))));
|
|
|
1722
|
|
|
1723 Append_To (Body_List, Proc_Body);
|
|
|
1724
|
|
|
1725 -- The initial condition procedure requires debug info when initial
|
|
|
1726 -- condition is subject to Source Coverage Obligations.
|
|
|
1727
|
|
|
1728 Proc_Body_Id := Defining_Entity (Proc_Body);
|
|
|
1729
|
|
|
1730 if Generate_SCO then
|
|
145
|
1731 Set_Debug_Info_Needed (Proc_Body_Id);
|
|
111
|
1732 end if;
|
|
|
1733
|
|
|
1734 -- The location of the initial condition procedure call must be as close
|
|
|
1735 -- as possible to the intended semantic location of the check because
|
|
|
1736 -- the ABE mechanism relies heavily on accurate locations.
|
|
|
1737
|
|
|
1738 Call_Loc := End_Keyword_Location (N);
|
|
|
1739
|
|
|
1740 -- Generate:
|
|
|
1741 -- <Pack_Id>Initial_Condition;
|
|
|
1742
|
|
|
1743 Call :=
|
|
|
1744 Make_Procedure_Call_Statement (Call_Loc,
|
|
|
1745 Name => New_Occurrence_Of (Proc_Id, Call_Loc));
|
|
|
1746
|
|
|
1747 Append_To (Call_List, Call);
|
|
|
1748
|
|
|
1749 Analyze (Proc_Decl);
|
|
|
1750 Analyze (Proc_Body);
|
|
|
1751 Analyze (Call);
|
|
|
1752 end Expand_Pragma_Initial_Condition;
|
|
|
1753
|
|
|
1754 ------------------------------------
|
|
|
1755 -- Expand_Pragma_Inspection_Point --
|
|
|
1756 ------------------------------------
|
|
|
1757
|
|
|
1758 -- If no argument is given, then we supply a default argument list that
|
|
|
1759 -- includes all objects declared at the source level in all subprograms
|
|
|
1760 -- that enclose the inspection point pragma.
|
|
|
1761
|
|
|
1762 procedure Expand_Pragma_Inspection_Point (N : Node_Id) is
|
|
|
1763 Loc : constant Source_Ptr := Sloc (N);
|
|
|
1764 A : List_Id;
|
|
|
1765 Assoc : Node_Id;
|
|
|
1766 S : Entity_Id;
|
|
|
1767 E : Entity_Id;
|
|
|
1768
|
|
|
1769 begin
|
|
|
1770 if No (Pragma_Argument_Associations (N)) then
|
|
|
1771 A := New_List;
|
|
|
1772 S := Current_Scope;
|
|
|
1773
|
|
|
1774 while S /= Standard_Standard loop
|
|
|
1775 E := First_Entity (S);
|
|
|
1776 while Present (E) loop
|
|
|
1777 if Comes_From_Source (E)
|
|
|
1778 and then Is_Object (E)
|
|
|
1779 and then not Is_Entry_Formal (E)
|
|
|
1780 and then Ekind (E) /= E_Component
|
|
|
1781 and then Ekind (E) /= E_Discriminant
|
|
|
1782 and then Ekind (E) /= E_Generic_In_Parameter
|
|
|
1783 and then Ekind (E) /= E_Generic_In_Out_Parameter
|
|
|
1784 then
|
|
|
1785 Append_To (A,
|
|
|
1786 Make_Pragma_Argument_Association (Loc,
|
|
|
1787 Expression => New_Occurrence_Of (E, Loc)));
|
|
|
1788 end if;
|
|
|
1789
|
|
|
1790 Next_Entity (E);
|
|
|
1791 end loop;
|
|
|
1792
|
|
|
1793 S := Scope (S);
|
|
|
1794 end loop;
|
|
|
1795
|
|
|
1796 Set_Pragma_Argument_Associations (N, A);
|
|
|
1797 end if;
|
|
|
1798
|
|
|
1799 -- Expand the arguments of the pragma. Expanding an entity reference
|
|
|
1800 -- is a noop, except in a protected operation, where a reference may
|
|
|
1801 -- have to be transformed into a reference to the corresponding prival.
|
|
|
1802 -- Are there other pragmas that may require this ???
|
|
|
1803
|
|
|
1804 Assoc := First (Pragma_Argument_Associations (N));
|
|
|
1805 while Present (Assoc) loop
|
|
|
1806 Expand (Expression (Assoc));
|
|
|
1807 Next (Assoc);
|
|
|
1808 end loop;
|
|
|
1809 end Expand_Pragma_Inspection_Point;
|
|
|
1810
|
|
|
1811 --------------------------------------
|
|
|
1812 -- Expand_Pragma_Interrupt_Priority --
|
|
|
1813 --------------------------------------
|
|
|
1814
|
|
|
1815 -- Supply default argument if none exists (System.Interrupt_Priority'Last)
|
|
|
1816
|
|
|
1817 procedure Expand_Pragma_Interrupt_Priority (N : Node_Id) is
|
|
|
1818 Loc : constant Source_Ptr := Sloc (N);
|
|
|
1819 begin
|
|
|
1820 if No (Pragma_Argument_Associations (N)) then
|
|
|
1821 Set_Pragma_Argument_Associations (N, New_List (
|
|
|
1822 Make_Pragma_Argument_Association (Loc,
|
|
|
1823 Expression =>
|
|
|
1824 Make_Attribute_Reference (Loc,
|
|
|
1825 Prefix =>
|
|
|
1826 New_Occurrence_Of (RTE (RE_Interrupt_Priority), Loc),
|
|
|
1827 Attribute_Name => Name_Last))));
|
|
|
1828 end if;
|
|
|
1829 end Expand_Pragma_Interrupt_Priority;
|
|
|
1830
|
|
|
1831 --------------------------------
|
|
|
1832 -- Expand_Pragma_Loop_Variant --
|
|
|
1833 --------------------------------
|
|
|
1834
|
|
|
1835 -- Pragma Loop_Variant is expanded in the following manner:
|
|
|
1836
|
|
|
1837 -- Original code
|
|
|
1838
|
|
|
1839 -- for | while ... loop
|
|
|
1840 -- <preceding source statements>
|
|
|
1841 -- pragma Loop_Variant
|
|
|
1842 -- (Increases => Incr_Expr,
|
|
|
1843 -- Decreases => Decr_Expr);
|
|
|
1844 -- <succeeding source statements>
|
|
|
1845 -- end loop;
|
|
|
1846
|
|
|
1847 -- Expanded code
|
|
|
1848
|
|
|
1849 -- Curr_1 : <type of Incr_Expr>;
|
|
|
1850 -- Curr_2 : <type of Decr_Expr>;
|
|
|
1851 -- Old_1 : <type of Incr_Expr>;
|
|
|
1852 -- Old_2 : <type of Decr_Expr>;
|
|
|
1853 -- Flag : Boolean := False;
|
|
|
1854
|
|
|
1855 -- for | while ... loop
|
|
|
1856 -- <preceding source statements>
|
|
|
1857
|
|
|
1858 -- if Flag then
|
|
|
1859 -- Old_1 := Curr_1;
|
|
|
1860 -- Old_2 := Curr_2;
|
|
|
1861 -- end if;
|
|
|
1862
|
|
|
1863 -- Curr_1 := <Incr_Expr>;
|
|
|
1864 -- Curr_2 := <Decr_Expr>;
|
|
|
1865
|
|
|
1866 -- if Flag then
|
|
|
1867 -- if Curr_1 /= Old_1 then
|
|
|
1868 -- pragma Check (Loop_Variant, Curr_1 > Old_1);
|
|
|
1869 -- else
|
|
|
1870 -- pragma Check (Loop_Variant, Curr_2 < Old_2);
|
|
|
1871 -- end if;
|
|
|
1872 -- else
|
|
|
1873 -- Flag := True;
|
|
|
1874 -- end if;
|
|
|
1875
|
|
|
1876 -- <succeeding source statements>
|
|
|
1877 -- end loop;
|
|
|
1878
|
|
|
1879 procedure Expand_Pragma_Loop_Variant (N : Node_Id) is
|
|
|
1880 Loc : constant Source_Ptr := Sloc (N);
|
|
|
1881 Last_Var : constant Node_Id :=
|
|
|
1882 Last (Pragma_Argument_Associations (N));
|
|
|
1883
|
|
|
1884 Curr_Assign : List_Id := No_List;
|
|
|
1885 Flag_Id : Entity_Id := Empty;
|
|
|
1886 If_Stmt : Node_Id := Empty;
|
|
|
1887 Old_Assign : List_Id := No_List;
|
|
|
1888 Loop_Scop : Entity_Id;
|
|
|
1889 Loop_Stmt : Node_Id;
|
|
|
1890 Variant : Node_Id;
|
|
|
1891
|
|
|
1892 procedure Process_Variant (Variant : Node_Id; Is_Last : Boolean);
|
|
|
1893 -- Process a single increasing / decreasing termination variant. Flag
|
|
|
1894 -- Is_Last should be set when processing the last variant.
|
|
|
1895
|
|
|
1896 ---------------------
|
|
|
1897 -- Process_Variant --
|
|
|
1898 ---------------------
|
|
|
1899
|
|
|
1900 procedure Process_Variant (Variant : Node_Id; Is_Last : Boolean) is
|
|
|
1901 function Make_Op
|
|
|
1902 (Loc : Source_Ptr;
|
|
|
1903 Curr_Val : Node_Id;
|
|
|
1904 Old_Val : Node_Id) return Node_Id;
|
|
|
1905 -- Generate a comparison between Curr_Val and Old_Val depending on
|
|
|
1906 -- the change mode (Increases / Decreases) of the variant.
|
|
|
1907
|
|
|
1908 -------------
|
|
|
1909 -- Make_Op --
|
|
|
1910 -------------
|
|
|
1911
|
|
|
1912 function Make_Op
|
|
|
1913 (Loc : Source_Ptr;
|
|
|
1914 Curr_Val : Node_Id;
|
|
|
1915 Old_Val : Node_Id) return Node_Id
|
|
|
1916 is
|
|
|
1917 begin
|
|
|
1918 if Chars (Variant) = Name_Increases then
|
|
|
1919 return Make_Op_Gt (Loc, Curr_Val, Old_Val);
|
|
|
1920 else pragma Assert (Chars (Variant) = Name_Decreases);
|
|
|
1921 return Make_Op_Lt (Loc, Curr_Val, Old_Val);
|
|
|
1922 end if;
|
|
|
1923 end Make_Op;
|
|
|
1924
|
|
|
1925 -- Local variables
|
|
|
1926
|
|
|
1927 Expr : constant Node_Id := Expression (Variant);
|
|
|
1928 Expr_Typ : constant Entity_Id := Etype (Expr);
|
|
|
1929 Loc : constant Source_Ptr := Sloc (Expr);
|
|
|
1930 Loop_Loc : constant Source_Ptr := Sloc (Loop_Stmt);
|
|
|
1931 Curr_Id : Entity_Id;
|
|
|
1932 Old_Id : Entity_Id;
|
|
|
1933 Prag : Node_Id;
|
|
|
1934
|
|
|
1935 -- Start of processing for Process_Variant
|
|
|
1936
|
|
|
1937 begin
|
|
|
1938 -- All temporaries generated in this routine must be inserted before
|
|
|
1939 -- the related loop statement. Ensure that the proper scope is on the
|
|
|
1940 -- stack when analyzing the temporaries. Note that we also use the
|
|
|
1941 -- Sloc of the related loop.
|
|
|
1942
|
|
|
1943 Push_Scope (Scope (Loop_Scop));
|
|
|
1944
|
|
|
1945 -- Step 1: Create the declaration of the flag which controls the
|
|
|
1946 -- behavior of the assertion on the first iteration of the loop.
|
|
|
1947
|
|
|
1948 if No (Flag_Id) then
|
|
|
1949
|
|
|
1950 -- Generate:
|
|
|
1951 -- Flag : Boolean := False;
|
|
|
1952
|
|
|
1953 Flag_Id := Make_Temporary (Loop_Loc, 'F');
|
|
|
1954
|
|
|
1955 Insert_Action (Loop_Stmt,
|
|
|
1956 Make_Object_Declaration (Loop_Loc,
|
|
|
1957 Defining_Identifier => Flag_Id,
|
|
|
1958 Object_Definition =>
|
|
|
1959 New_Occurrence_Of (Standard_Boolean, Loop_Loc),
|
|
|
1960 Expression =>
|
|
|
1961 New_Occurrence_Of (Standard_False, Loop_Loc)));
|
|
|
1962
|
|
|
1963 -- Prevent an unwanted optimization where the Current_Value of
|
|
|
1964 -- the flag eliminates the if statement which stores the variant
|
|
|
1965 -- values coming from the previous iteration.
|
|
|
1966
|
|
|
1967 -- Flag : Boolean := False;
|
|
|
1968 -- loop
|
|
|
1969 -- if Flag then -- condition rewritten to False
|
|
|
1970 -- Old_N := Curr_N; -- and if statement eliminated
|
|
|
1971 -- end if;
|
|
|
1972 -- . . .
|
|
|
1973 -- Flag := True;
|
|
|
1974 -- end loop;
|
|
|
1975
|
|
|
1976 Set_Current_Value (Flag_Id, Empty);
|
|
|
1977 end if;
|
|
|
1978
|
|
|
1979 -- Step 2: Create the temporaries which store the old and current
|
|
|
1980 -- values of the associated expression.
|
|
|
1981
|
|
|
1982 -- Generate:
|
|
|
1983 -- Curr : <type of Expr>;
|
|
|
1984
|
|
|
1985 Curr_Id := Make_Temporary (Loc, 'C');
|
|
|
1986
|
|
|
1987 Insert_Action (Loop_Stmt,
|
|
|
1988 Make_Object_Declaration (Loop_Loc,
|
|
|
1989 Defining_Identifier => Curr_Id,
|
|
|
1990 Object_Definition => New_Occurrence_Of (Expr_Typ, Loop_Loc)));
|
|
|
1991
|
|
|
1992 -- Generate:
|
|
|
1993 -- Old : <type of Expr>;
|
|
|
1994
|
|
|
1995 Old_Id := Make_Temporary (Loc, 'P');
|
|
|
1996
|
|
|
1997 Insert_Action (Loop_Stmt,
|
|
|
1998 Make_Object_Declaration (Loop_Loc,
|
|
|
1999 Defining_Identifier => Old_Id,
|
|
|
2000 Object_Definition => New_Occurrence_Of (Expr_Typ, Loop_Loc)));
|
|
|
2001
|
|
|
2002 -- Restore original scope after all temporaries have been analyzed
|
|
|
2003
|
|
|
2004 Pop_Scope;
|
|
|
2005
|
|
|
2006 -- Step 3: Store value of the expression from the previous iteration
|
|
|
2007
|
|
|
2008 if No (Old_Assign) then
|
|
|
2009 Old_Assign := New_List;
|
|
|
2010 end if;
|
|
|
2011
|
|
|
2012 -- Generate:
|
|
|
2013 -- Old := Curr;
|
|
|
2014
|
|
|
2015 Append_To (Old_Assign,
|
|
|
2016 Make_Assignment_Statement (Loc,
|
|
|
2017 Name => New_Occurrence_Of (Old_Id, Loc),
|
|
|
2018 Expression => New_Occurrence_Of (Curr_Id, Loc)));
|
|
|
2019
|
|
|
2020 -- Step 4: Store the current value of the expression
|
|
|
2021
|
|
|
2022 if No (Curr_Assign) then
|
|
|
2023 Curr_Assign := New_List;
|
|
|
2024 end if;
|
|
|
2025
|
|
|
2026 -- Generate:
|
|
|
2027 -- Curr := <Expr>;
|
|
|
2028
|
|
|
2029 Append_To (Curr_Assign,
|
|
|
2030 Make_Assignment_Statement (Loc,
|
|
|
2031 Name => New_Occurrence_Of (Curr_Id, Loc),
|
|
|
2032 Expression => Relocate_Node (Expr)));
|
|
|
2033
|
|
|
2034 -- Step 5: Create corresponding assertion to verify change of value
|
|
|
2035
|
|
|
2036 -- Generate:
|
|
|
2037 -- pragma Check (Loop_Variant, Curr <|> Old);
|
|
|
2038
|
|
|
2039 Prag :=
|
|
|
2040 Make_Pragma (Loc,
|
|
|
2041 Chars => Name_Check,
|
|
|
2042 Pragma_Argument_Associations => New_List (
|
|
|
2043 Make_Pragma_Argument_Association (Loc,
|
|
|
2044 Expression => Make_Identifier (Loc, Name_Loop_Variant)),
|
|
|
2045 Make_Pragma_Argument_Association (Loc,
|
|
|
2046 Expression =>
|
|
|
2047 Make_Op (Loc,
|
|
|
2048 Curr_Val => New_Occurrence_Of (Curr_Id, Loc),
|
|
|
2049 Old_Val => New_Occurrence_Of (Old_Id, Loc)))));
|
|
|
2050
|
|
|
2051 -- Generate:
|
|
|
2052 -- if Curr /= Old then
|
|
|
2053 -- <Prag>;
|
|
|
2054
|
|
|
2055 if No (If_Stmt) then
|
|
|
2056
|
|
|
2057 -- When there is just one termination variant, do not compare the
|
|
|
2058 -- old and current value for equality, just check the pragma.
|
|
|
2059
|
|
|
2060 if Is_Last then
|
|
|
2061 If_Stmt := Prag;
|
|
|
2062 else
|
|
|
2063 If_Stmt :=
|
|
|
2064 Make_If_Statement (Loc,
|
|
|
2065 Condition =>
|
|
|
2066 Make_Op_Ne (Loc,
|
|
|
2067 Left_Opnd => New_Occurrence_Of (Curr_Id, Loc),
|
|
|
2068 Right_Opnd => New_Occurrence_Of (Old_Id, Loc)),
|
|
|
2069 Then_Statements => New_List (Prag));
|
|
|
2070 end if;
|
|
|
2071
|
|
|
2072 -- Generate:
|
|
|
2073 -- else
|
|
|
2074 -- <Prag>;
|
|
|
2075 -- end if;
|
|
|
2076
|
|
|
2077 elsif Is_Last then
|
|
|
2078 Set_Else_Statements (If_Stmt, New_List (Prag));
|
|
|
2079
|
|
|
2080 -- Generate:
|
|
|
2081 -- elsif Curr /= Old then
|
|
|
2082 -- <Prag>;
|
|
|
2083
|
|
|
2084 else
|
|
|
2085 if Elsif_Parts (If_Stmt) = No_List then
|
|
|
2086 Set_Elsif_Parts (If_Stmt, New_List);
|
|
|
2087 end if;
|
|
|
2088
|
|
|
2089 Append_To (Elsif_Parts (If_Stmt),
|
|
|
2090 Make_Elsif_Part (Loc,
|
|
|
2091 Condition =>
|
|
|
2092 Make_Op_Ne (Loc,
|
|
|
2093 Left_Opnd => New_Occurrence_Of (Curr_Id, Loc),
|
|
|
2094 Right_Opnd => New_Occurrence_Of (Old_Id, Loc)),
|
|
|
2095 Then_Statements => New_List (Prag)));
|
|
|
2096 end if;
|
|
|
2097 end Process_Variant;
|
|
|
2098
|
|
|
2099 -- Start of processing for Expand_Pragma_Loop_Variant
|
|
|
2100
|
|
|
2101 begin
|
|
|
2102 -- If pragma is not enabled, rewrite as Null statement. If pragma is
|
|
|
2103 -- disabled, it has already been rewritten as a Null statement.
|
|
|
2104
|
|
|
2105 if Is_Ignored (N) then
|
|
|
2106 Rewrite (N, Make_Null_Statement (Loc));
|
|
|
2107 Analyze (N);
|
|
|
2108 return;
|
|
|
2109 end if;
|
|
|
2110
|
|
|
2111 -- The expansion of Loop_Variant is quite distributed as it produces
|
|
|
2112 -- various statements to capture and compare the arguments. To preserve
|
|
|
2113 -- the original context, set the Is_Assertion_Expr flag. This aids the
|
|
|
2114 -- Ghost legality checks when verifying the placement of a reference to
|
|
|
2115 -- a Ghost entity.
|
|
|
2116
|
|
|
2117 In_Assertion_Expr := In_Assertion_Expr + 1;
|
|
|
2118
|
|
|
2119 -- Locate the enclosing loop for which this assertion applies. In the
|
|
|
2120 -- case of Ada 2012 array iteration, we might be dealing with nested
|
|
|
2121 -- loops. Only the outermost loop has an identifier.
|
|
|
2122
|
|
|
2123 Loop_Stmt := N;
|
|
|
2124 while Present (Loop_Stmt) loop
|
|
|
2125 if Nkind (Loop_Stmt) = N_Loop_Statement
|
|
|
2126 and then Present (Identifier (Loop_Stmt))
|
|
|
2127 then
|
|
|
2128 exit;
|
|
|
2129 end if;
|
|
|
2130
|
|
|
2131 Loop_Stmt := Parent (Loop_Stmt);
|
|
|
2132 end loop;
|
|
|
2133
|
|
|
2134 Loop_Scop := Entity (Identifier (Loop_Stmt));
|
|
|
2135
|
|
|
2136 -- Create the circuitry which verifies individual variants
|
|
|
2137
|
|
|
2138 Variant := First (Pragma_Argument_Associations (N));
|
|
|
2139 while Present (Variant) loop
|
|
|
2140 Process_Variant (Variant, Is_Last => Variant = Last_Var);
|
|
|
2141 Next (Variant);
|
|
|
2142 end loop;
|
|
|
2143
|
|
|
2144 -- Construct the segment which stores the old values of all expressions.
|
|
|
2145 -- Generate:
|
|
|
2146 -- if Flag then
|
|
|
2147 -- <Old_Assign>
|
|
|
2148 -- end if;
|
|
|
2149
|
|
|
2150 Insert_Action (N,
|
|
|
2151 Make_If_Statement (Loc,
|
|
|
2152 Condition => New_Occurrence_Of (Flag_Id, Loc),
|
|
|
2153 Then_Statements => Old_Assign));
|
|
|
2154
|
|
|
2155 -- Update the values of all expressions
|
|
|
2156
|
|
|
2157 Insert_Actions (N, Curr_Assign);
|
|
|
2158
|
|
|
2159 -- Add the assertion circuitry to test all changes in expressions.
|
|
|
2160 -- Generate:
|
|
|
2161 -- if Flag then
|
|
|
2162 -- <If_Stmt>
|
|
|
2163 -- else
|
|
|
2164 -- Flag := True;
|
|
|
2165 -- end if;
|
|
|
2166
|
|
|
2167 Insert_Action (N,
|
|
|
2168 Make_If_Statement (Loc,
|
|
|
2169 Condition => New_Occurrence_Of (Flag_Id, Loc),
|
|
|
2170 Then_Statements => New_List (If_Stmt),
|
|
|
2171 Else_Statements => New_List (
|
|
|
2172 Make_Assignment_Statement (Loc,
|
|
|
2173 Name => New_Occurrence_Of (Flag_Id, Loc),
|
|
|
2174 Expression => New_Occurrence_Of (Standard_True, Loc)))));
|
|
|
2175
|
|
|
2176 -- Note: the pragma has been completely transformed into a sequence of
|
|
|
2177 -- corresponding declarations and statements. We leave it in the tree
|
|
|
2178 -- for documentation purposes. It will be ignored by the backend.
|
|
|
2179
|
|
|
2180 In_Assertion_Expr := In_Assertion_Expr - 1;
|
|
|
2181 end Expand_Pragma_Loop_Variant;
|
|
|
2182
|
|
|
2183 --------------------------------
|
|
|
2184 -- Expand_Pragma_Psect_Object --
|
|
|
2185 --------------------------------
|
|
|
2186
|
|
|
2187 -- Convert to Common_Object, and expand the resulting pragma
|
|
|
2188
|
|
|
2189 procedure Expand_Pragma_Psect_Object (N : Node_Id)
|
|
|
2190 renames Expand_Pragma_Common_Object;
|
|
|
2191
|
|
|
2192 -------------------------------------
|
|
|
2193 -- Expand_Pragma_Relative_Deadline --
|
|
|
2194 -------------------------------------
|
|
|
2195
|
|
|
2196 procedure Expand_Pragma_Relative_Deadline (N : Node_Id) is
|
|
|
2197 P : constant Node_Id := Parent (N);
|
|
|
2198 Loc : constant Source_Ptr := Sloc (N);
|
|
|
2199
|
|
|
2200 begin
|
|
|
2201 -- Expand the pragma only in the case of the main subprogram. For tasks
|
|
|
2202 -- the expansion is done in exp_ch9. Generate a call to Set_Deadline
|
|
|
2203 -- at Clock plus the relative deadline specified in the pragma. Time
|
|
|
2204 -- values are translated into Duration to allow for non-private
|
|
|
2205 -- addition operation.
|
|
|
2206
|
|
|
2207 if Nkind (P) = N_Subprogram_Body then
|
|
|
2208 Rewrite
|
|
|
2209 (N,
|
|
|
2210 Make_Procedure_Call_Statement (Loc,
|
|
|
2211 Name => New_Occurrence_Of (RTE (RE_Set_Deadline), Loc),
|
|
|
2212 Parameter_Associations => New_List (
|
|
|
2213 Unchecked_Convert_To (RTE (RO_RT_Time),
|
|
|
2214 Make_Op_Add (Loc,
|
|
|
2215 Left_Opnd =>
|
|
|
2216 Make_Function_Call (Loc,
|
|
|
2217 New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc),
|
|
|
2218 New_List
|
|
|
2219 (Make_Function_Call
|
|
|
2220 (Loc, New_Occurrence_Of (RTE (RE_Clock), Loc)))),
|
|
|
2221 Right_Opnd =>
|
|
|
2222 Unchecked_Convert_To (Standard_Duration, Arg1 (N)))))));
|
|
|
2223
|
|
|
2224 Analyze (N);
|
|
|
2225 end if;
|
|
|
2226 end Expand_Pragma_Relative_Deadline;
|
|
|
2227
|
|
|
2228 -------------------------------------------
|
|
|
2229 -- Expand_Pragma_Suppress_Initialization --
|
|
|
2230 -------------------------------------------
|
|
|
2231
|
|
|
2232 procedure Expand_Pragma_Suppress_Initialization (N : Node_Id) is
|
|
|
2233 Def_Id : constant Entity_Id := Entity (Arg1 (N));
|
|
|
2234
|
|
|
2235 begin
|
|
|
2236 -- Variable case (we have to undo any initialization already done)
|
|
|
2237
|
|
|
2238 if Ekind (Def_Id) = E_Variable then
|
|
|
2239 Undo_Initialization (Def_Id, N);
|
|
|
2240 end if;
|
|
|
2241 end Expand_Pragma_Suppress_Initialization;
|
|
|
2242
|
|
|
2243 -------------------------
|
|
|
2244 -- Undo_Initialization --
|
|
|
2245 -------------------------
|
|
|
2246
|
|
|
2247 procedure Undo_Initialization (Def_Id : Entity_Id; N : Node_Id) is
|
|
|
2248 Init_Call : Node_Id;
|
|
|
2249
|
|
|
2250 begin
|
|
|
2251 -- When applied to a variable, the default initialization must not be
|
|
|
2252 -- done. As it is already done when the pragma is found, we just get rid
|
|
|
2253 -- of the call the initialization procedure which followed the object
|
|
|
2254 -- declaration. The call is inserted after the declaration, but validity
|
|
|
2255 -- checks may also have been inserted and thus the initialization call
|
|
|
2256 -- does not necessarily appear immediately after the object declaration.
|
|
|
2257
|
|
|
2258 -- We can't use the freezing mechanism for this purpose, since we have
|
|
|
2259 -- to elaborate the initialization expression when it is first seen (so
|
|
|
2260 -- this elaboration cannot be deferred to the freeze point).
|
|
|
2261
|
|
|
2262 -- Find and remove generated initialization call for object, if any
|
|
|
2263
|
|
|
2264 Init_Call := Remove_Init_Call (Def_Id, Rep_Clause => N);
|
|
|
2265
|
|
|
2266 -- Any default initialization expression should be removed (e.g.
|
|
|
2267 -- null defaults for access objects, zero initialization of packed
|
|
|
2268 -- bit arrays). Imported objects aren't allowed to have explicit
|
|
|
2269 -- initialization, so the expression must have been generated by
|
|
|
2270 -- the compiler.
|
|
|
2271
|
|
|
2272 if No (Init_Call) and then Present (Expression (Parent (Def_Id))) then
|
|
|
2273 Set_Expression (Parent (Def_Id), Empty);
|
|
|
2274 end if;
|
|
|
2275
|
|
|
2276 -- The object may not have any initialization, but in the presence of
|
|
|
2277 -- Initialize_Scalars code is inserted after then declaration, which
|
|
|
2278 -- must now be removed as well. The code carries the same source
|
|
|
2279 -- location as the declaration itself.
|
|
|
2280
|
|
|
2281 if Initialize_Scalars and then Is_Array_Type (Etype (Def_Id)) then
|
|
|
2282 declare
|
|
|
2283 Init : Node_Id;
|
|
|
2284 Nxt : Node_Id;
|
|
|
2285 begin
|
|
|
2286 Init := Next (Parent (Def_Id));
|
|
|
2287 while not Comes_From_Source (Init)
|
|
|
2288 and then Sloc (Init) = Sloc (Def_Id)
|
|
|
2289 loop
|
|
|
2290 Nxt := Next (Init);
|
|
|
2291 Remove (Init);
|
|
|
2292 Init := Nxt;
|
|
|
2293 end loop;
|
|
|
2294 end;
|
|
|
2295 end if;
|
|
|
2296 end Undo_Initialization;
|
|
|
2297
|
|
|
2298 end Exp_Prag;
|
