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