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