?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Concretize three gimple_return_ accessors
[official-gcc.git] / gcc / ada / exp_prag.adb
blobae97013a5c557c3d173a29efd718b808ab899462
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, Strval => "common_object")),
1163 Make_Pragma_Argument_Association (Ploc,
1164 Expression => New_Copy_Tree (Psect)))));
1165 end Expand_Pragma_Common_Object;
1166
1167 ---------------------------------------
1168 -- Expand_Pragma_Import_Or_Interface --
1169 ---------------------------------------
1170
1171 procedure Expand_Pragma_Import_Or_Interface (N : Node_Id) is
1172 Def_Id : Entity_Id;
1173 Init_Call : Node_Id;
1174
1175 begin
1176 -- In Relaxed_RM_Semantics, support old Ada 83 style:
1177 -- pragma Import (Entity, "external name");
1178
1179 if Relaxed_RM_Semantics
1180 and then List_Length (Pragma_Argument_Associations (N)) = 2
1181 and then Chars (Pragma_Identifier (N)) = Name_Import
1182 and then Nkind (Arg2 (N)) = N_String_Literal
1183 then
1184 Def_Id := Entity (Arg1 (N));
1185 else
1186 Def_Id := Entity (Arg2 (N));
1187 end if;
1188
1189 -- Variable case
1190
1191 if Ekind (Def_Id) = E_Variable then
1192
1193 -- When applied to a variable, the default initialization must not be
1194 -- done. As it is already done when the pragma is found, we just get
1195 -- rid of the call the initialization procedure which followed the
1196 -- object declaration. The call is inserted after the declaration,
1197 -- but validity checks may also have been inserted and thus the
1198 -- initialization call does not necessarily appear immediately
1199 -- after the object declaration.
1200
1201 -- We can't use the freezing mechanism for this purpose, since we
1202 -- have to elaborate the initialization expression when it is first
1203 -- seen (so this elaboration cannot be deferred to the freeze point).
1204
1205 -- Find and remove generated initialization call for object, if any
1206
1207 Init_Call := Remove_Init_Call (Def_Id, Rep_Clause => N);
1208
1209 -- Any default initialization expression should be removed (e.g.
1210 -- null defaults for access objects, zero initialization of packed
1211 -- bit arrays). Imported objects aren't allowed to have explicit
1212 -- initialization, so the expression must have been generated by
1213 -- the compiler.
1214
1215 if No (Init_Call) and then Present (Expression (Parent (Def_Id))) then
1216 Set_Expression (Parent (Def_Id), Empty);
1217 end if;
1218
1219 -- Case of exception with convention C++
1220
1221 elsif Ekind (Def_Id) = E_Exception
1222 and then Convention (Def_Id) = Convention_CPP
1223 then
1224 -- Import a C++ convention
1225
1226 declare
1227 Loc : constant Source_Ptr := Sloc (N);
1228 Rtti_Name : constant Node_Id := Arg3 (N);
1229 Dum : constant Entity_Id := Make_Temporary (Loc, 'D');
1230 Exdata : List_Id;
1231 Lang_Char : Node_Id;
1232 Foreign_Data : Node_Id;
1233
1234 begin
1235 Exdata := Component_Associations (Expression (Parent (Def_Id)));
1236
1237 Lang_Char := Next (First (Exdata));
1238
1239 -- Change the one-character language designator to 'C'
1240
1241 Rewrite (Expression (Lang_Char),
1242 Make_Character_Literal (Loc,
1243 Chars => Name_uC,
1244 Char_Literal_Value => UI_From_Int (Character'Pos ('C'))));
1245 Analyze (Expression (Lang_Char));
1246
1247 -- Change the value of Foreign_Data
1248
1249 Foreign_Data := Next (Next (Next (Next (Lang_Char))));
1250
1251 Insert_Actions (Def_Id, New_List (
1252 Make_Object_Declaration (Loc,
1253 Defining_Identifier => Dum,
1254 Object_Definition =>
1255 New_Occurrence_Of (Standard_Character, Loc)),
1256
1257 Make_Pragma (Loc,
1258 Chars => Name_Import,
1259 Pragma_Argument_Associations => New_List (
1260 Make_Pragma_Argument_Association (Loc,
1261 Expression => Make_Identifier (Loc, Name_Ada)),
1262
1263 Make_Pragma_Argument_Association (Loc,
1264 Expression => Make_Identifier (Loc, Chars (Dum))),
1265
1266 Make_Pragma_Argument_Association (Loc,
1267 Chars => Name_External_Name,
1268 Expression => Relocate_Node (Rtti_Name))))));
1269
1270 Rewrite (Expression (Foreign_Data),
1271 Unchecked_Convert_To (Standard_A_Char,
1272 Make_Attribute_Reference (Loc,
1273 Prefix => Make_Identifier (Loc, Chars (Dum)),
1274 Attribute_Name => Name_Address)));
1275 Analyze (Expression (Foreign_Data));
1276 end;
1277
1278 -- No special expansion required for any other case
1279
1280 else
1281 null;
1282 end if;
1283 end Expand_Pragma_Import_Or_Interface;
1284
1285 -------------------------------------
1286 -- Expand_Pragma_Initial_Condition --
1287 -------------------------------------
1288
1289 procedure Expand_Pragma_Initial_Condition (Spec_Or_Body : Node_Id) is
1290 Loc : constant Source_Ptr := Sloc (Spec_Or_Body);
1291 Check : Node_Id;
1292 Expr : Node_Id;
1293 Init_Cond : Node_Id;
1294 List : List_Id;
1295 Pack_Id : Entity_Id;
1296
1297 begin
1298 if Nkind (Spec_Or_Body) = N_Package_Body then
1299 Pack_Id := Corresponding_Spec (Spec_Or_Body);
1300
1301 if Present (Handled_Statement_Sequence (Spec_Or_Body)) then
1302 List := Statements (Handled_Statement_Sequence (Spec_Or_Body));
1303
1304 -- The package body lacks statements, create an empty list
1305
1306 else
1307 List := New_List;
1308
1309 Set_Handled_Statement_Sequence (Spec_Or_Body,
1310 Make_Handled_Sequence_Of_Statements (Loc, Statements => List));
1311 end if;
1312
1313 elsif Nkind (Spec_Or_Body) = N_Package_Declaration then
1314 Pack_Id := Defining_Entity (Spec_Or_Body);
1315
1316 if Present (Visible_Declarations (Specification (Spec_Or_Body))) then
1317 List := Visible_Declarations (Specification (Spec_Or_Body));
1318
1319 -- The package lacks visible declarations, create an empty list
1320
1321 else
1322 List := New_List;
1323
1324 Set_Visible_Declarations (Specification (Spec_Or_Body), List);
1325 end if;
1326
1327 -- This routine should not be used on anything other than packages
1328
1329 else
1330 raise Program_Error;
1331 end if;
1332
1333 Init_Cond := Get_Pragma (Pack_Id, Pragma_Initial_Condition);
1334
1335 -- The caller should check whether the package is subject to pragma
1336 -- Initial_Condition.
1337
1338 pragma Assert (Present (Init_Cond));
1339
1340 Expr :=
1341 Get_Pragma_Arg (First (Pragma_Argument_Associations (Init_Cond)));
1342
1343 -- The assertion expression was found to be illegal, do not generate the
1344 -- runtime check as it will repeat the illegality.
1345
1346 if Error_Posted (Init_Cond) or else Error_Posted (Expr) then
1347 return;
1348 end if;
1349
1350 -- Generate:
1351 -- pragma Check (Initial_Condition, <Expr>);
1352
1353 Check :=
1354 Make_Pragma (Loc,
1355 Chars => Name_Check,
1356 Pragma_Argument_Associations => New_List (
1357 Make_Pragma_Argument_Association (Loc,
1358 Expression => Make_Identifier (Loc, Name_Initial_Condition)),
1359
1360 Make_Pragma_Argument_Association (Loc,
1361 Expression => New_Copy_Tree (Expr))));
1362
1363 Append_To (List, Check);
1364 Analyze (Check);
1365 end Expand_Pragma_Initial_Condition;
1366
1367 ------------------------------------
1368 -- Expand_Pragma_Inspection_Point --
1369 ------------------------------------
1370
1371 -- If no argument is given, then we supply a default argument list that
1372 -- includes all objects declared at the source level in all subprograms
1373 -- that enclose the inspection point pragma.
1374
1375 procedure Expand_Pragma_Inspection_Point (N : Node_Id) is
1376 Loc : constant Source_Ptr := Sloc (N);
1377 A : List_Id;
1378 Assoc : Node_Id;
1379 S : Entity_Id;
1380 E : Entity_Id;
1381
1382 begin
1383 if No (Pragma_Argument_Associations (N)) then
1384 A := New_List;
1385 S := Current_Scope;
1386
1387 while S /= Standard_Standard loop
1388 E := First_Entity (S);
1389 while Present (E) loop
1390 if Comes_From_Source (E)
1391 and then Is_Object (E)
1392 and then not Is_Entry_Formal (E)
1393 and then Ekind (E) /= E_Component
1394 and then Ekind (E) /= E_Discriminant
1395 and then Ekind (E) /= E_Generic_In_Parameter
1396 and then Ekind (E) /= E_Generic_In_Out_Parameter
1397 then
1398 Append_To (A,
1399 Make_Pragma_Argument_Association (Loc,
1400 Expression => New_Occurrence_Of (E, Loc)));
1401 end if;
1402
1403 Next_Entity (E);
1404 end loop;
1405
1406 S := Scope (S);
1407 end loop;
1408
1409 Set_Pragma_Argument_Associations (N, A);
1410 end if;
1411
1412 -- Expand the arguments of the pragma. Expanding an entity reference
1413 -- is a noop, except in a protected operation, where a reference may
1414 -- have to be transformed into a reference to the corresponding prival.
1415 -- Are there other pragmas that may require this ???
1416
1417 Assoc := First (Pragma_Argument_Associations (N));
1418
1419 while Present (Assoc) loop
1420 Expand (Expression (Assoc));
1421 Next (Assoc);
1422 end loop;
1423 end Expand_Pragma_Inspection_Point;
1424
1425 --------------------------------------
1426 -- Expand_Pragma_Interrupt_Priority --
1427 --------------------------------------
1428
1429 -- Supply default argument if none exists (System.Interrupt_Priority'Last)
1430
1431 procedure Expand_Pragma_Interrupt_Priority (N : Node_Id) is
1432 Loc : constant Source_Ptr := Sloc (N);
1433
1434 begin
1435 if No (Pragma_Argument_Associations (N)) then
1436 Set_Pragma_Argument_Associations (N, New_List (
1437 Make_Pragma_Argument_Association (Loc,
1438 Expression =>
1439 Make_Attribute_Reference (Loc,
1440 Prefix =>
1441 New_Occurrence_Of (RTE (RE_Interrupt_Priority), Loc),
1442 Attribute_Name => Name_Last))));
1443 end if;
1444 end Expand_Pragma_Interrupt_Priority;
1445
1446 --------------------------------
1447 -- Expand_Pragma_Loop_Variant --
1448 --------------------------------
1449
1450 -- Pragma Loop_Variant is expanded in the following manner:
1451
1452 -- Original code
1453
1454 -- for | while ... loop
1455 -- <preceding source statements>
1456 -- pragma Loop_Variant
1457 -- (Increases => Incr_Expr,
1458 -- Decreases => Decr_Expr);
1459 -- <succeeding source statements>
1460 -- end loop;
1461
1462 -- Expanded code
1463
1464 -- Curr_1 : <type of Incr_Expr>;
1465 -- Curr_2 : <type of Decr_Expr>;
1466 -- Old_1 : <type of Incr_Expr>;
1467 -- Old_2 : <type of Decr_Expr>;
1468 -- Flag : Boolean := False;
1469
1470 -- for | while ... loop
1471 -- <preceding source statements>
1472
1473 -- if Flag then
1474 -- Old_1 := Curr_1;
1475 -- Old_2 := Curr_2;
1476 -- end if;
1477
1478 -- Curr_1 := <Incr_Expr>;
1479 -- Curr_2 := <Decr_Expr>;
1480
1481 -- if Flag then
1482 -- if Curr_1 /= Old_1 then
1483 -- pragma Check (Loop_Variant, Curr_1 > Old_1);
1484 -- else
1485 -- pragma Check (Loop_Variant, Curr_2 < Old_2);
1486 -- end if;
1487 -- else
1488 -- Flag := True;
1489 -- end if;
1490
1491 -- <succeeding source statements>
1492 -- end loop;
1493
1494 procedure Expand_Pragma_Loop_Variant (N : Node_Id) is
1495 Loc : constant Source_Ptr := Sloc (N);
1496
1497 Last_Var : constant Node_Id := Last (Pragma_Argument_Associations (N));
1498
1499 Curr_Assign : List_Id := No_List;
1500 Flag_Id : Entity_Id := Empty;
1501 If_Stmt : Node_Id := Empty;
1502 Old_Assign : List_Id := No_List;
1503 Loop_Scop : Entity_Id;
1504 Loop_Stmt : Node_Id;
1505 Variant : Node_Id;
1506
1507 procedure Process_Variant (Variant : Node_Id; Is_Last : Boolean);
1508 -- Process a single increasing / decreasing termination variant. Flag
1509 -- Is_Last should be set when processing the last variant.
1510
1511 ---------------------
1512 -- Process_Variant --
1513 ---------------------
1514
1515 procedure Process_Variant (Variant : Node_Id; Is_Last : Boolean) is
1516 function Make_Op
1517 (Loc : Source_Ptr;
1518 Curr_Val : Node_Id;
1519 Old_Val : Node_Id) return Node_Id;
1520 -- Generate a comparison between Curr_Val and Old_Val depending on
1521 -- the change mode (Increases / Decreases) of the variant.
1522
1523 -------------
1524 -- Make_Op --
1525 -------------
1526
1527 function Make_Op
1528 (Loc : Source_Ptr;
1529 Curr_Val : Node_Id;
1530 Old_Val : Node_Id) return Node_Id
1531 is
1532 begin
1533 if Chars (Variant) = Name_Increases then
1534 return Make_Op_Gt (Loc, Curr_Val, Old_Val);
1535 else pragma Assert (Chars (Variant) = Name_Decreases);
1536 return Make_Op_Lt (Loc, Curr_Val, Old_Val);
1537 end if;
1538 end Make_Op;
1539
1540 -- Local variables
1541
1542 Expr : constant Node_Id := Expression (Variant);
1543 Expr_Typ : constant Entity_Id := Etype (Expr);
1544 Loc : constant Source_Ptr := Sloc (Expr);
1545 Loop_Loc : constant Source_Ptr := Sloc (Loop_Stmt);
1546 Curr_Id : Entity_Id;
1547 Old_Id : Entity_Id;
1548 Prag : Node_Id;
1549
1550 -- Start of processing for Process_Variant
1551
1552 begin
1553 -- All temporaries generated in this routine must be inserted before
1554 -- the related loop statement. Ensure that the proper scope is on the
1555 -- stack when analyzing the temporaries. Note that we also use the
1556 -- Sloc of the related loop.
1557
1558 Push_Scope (Scope (Loop_Scop));
1559
1560 -- Step 1: Create the declaration of the flag which controls the
1561 -- behavior of the assertion on the first iteration of the loop.
1562
1563 if No (Flag_Id) then
1564
1565 -- Generate:
1566 -- Flag : Boolean := False;
1567
1568 Flag_Id := Make_Temporary (Loop_Loc, 'F');
1569
1570 Insert_Action (Loop_Stmt,
1571 Make_Object_Declaration (Loop_Loc,
1572 Defining_Identifier => Flag_Id,
1573 Object_Definition =>
1574 New_Occurrence_Of (Standard_Boolean, Loop_Loc),
1575 Expression =>
1576 New_Occurrence_Of (Standard_False, Loop_Loc)));
1577
1578 -- Prevent an unwanted optimization where the Current_Value of
1579 -- the flag eliminates the if statement which stores the variant
1580 -- values coming from the previous iteration.
1581
1582 -- Flag : Boolean := False;
1583 -- loop
1584 -- if Flag then -- condition rewritten to False
1585 -- Old_N := Curr_N; -- and if statement eliminated
1586 -- end if;
1587 -- . . .
1588 -- Flag := True;
1589 -- end loop;
1590
1591 Set_Current_Value (Flag_Id, Empty);
1592 end if;
1593
1594 -- Step 2: Create the temporaries which store the old and current
1595 -- values of the associated expression.
1596
1597 -- Generate:
1598 -- Curr : <type of Expr>;
1599
1600 Curr_Id := Make_Temporary (Loc, 'C');
1601
1602 Insert_Action (Loop_Stmt,
1603 Make_Object_Declaration (Loop_Loc,
1604 Defining_Identifier => Curr_Id,
1605 Object_Definition => New_Occurrence_Of (Expr_Typ, Loop_Loc)));
1606
1607 -- Generate:
1608 -- Old : <type of Expr>;
1609
1610 Old_Id := Make_Temporary (Loc, 'P');
1611
1612 Insert_Action (Loop_Stmt,
1613 Make_Object_Declaration (Loop_Loc,
1614 Defining_Identifier => Old_Id,
1615 Object_Definition => New_Occurrence_Of (Expr_Typ, Loop_Loc)));
1616
1617 -- Restore original scope after all temporaries have been analyzed
1618
1619 Pop_Scope;
1620
1621 -- Step 3: Store value of the expression from the previous iteration
1622
1623 if No (Old_Assign) then
1624 Old_Assign := New_List;
1625 end if;
1626
1627 -- Generate:
1628 -- Old := Curr;
1629
1630 Append_To (Old_Assign,
1631 Make_Assignment_Statement (Loc,
1632 Name => New_Occurrence_Of (Old_Id, Loc),
1633 Expression => New_Occurrence_Of (Curr_Id, Loc)));
1634
1635 -- Step 4: Store the current value of the expression
1636
1637 if No (Curr_Assign) then
1638 Curr_Assign := New_List;
1639 end if;
1640
1641 -- Generate:
1642 -- Curr := <Expr>;
1643
1644 Append_To (Curr_Assign,
1645 Make_Assignment_Statement (Loc,
1646 Name => New_Occurrence_Of (Curr_Id, Loc),
1647 Expression => Relocate_Node (Expr)));
1648
1649 -- Step 5: Create corresponding assertion to verify change of value
1650
1651 -- Generate:
1652 -- pragma Check (Loop_Variant, Curr <|> Old);
1653
1654 Prag :=
1655 Make_Pragma (Loc,
1656 Chars => Name_Check,
1657 Pragma_Argument_Associations => New_List (
1658 Make_Pragma_Argument_Association (Loc,
1659 Expression => Make_Identifier (Loc, Name_Loop_Variant)),
1660 Make_Pragma_Argument_Association (Loc,
1661 Expression =>
1662 Make_Op (Loc,
1663 Curr_Val => New_Occurrence_Of (Curr_Id, Loc),
1664 Old_Val => New_Occurrence_Of (Old_Id, Loc)))));
1665
1666 -- Generate:
1667 -- if Curr /= Old then
1668 -- <Prag>;
1669
1670 if No (If_Stmt) then
1671
1672 -- When there is just one termination variant, do not compare the
1673 -- old and current value for equality, just check the pragma.
1674
1675 if Is_Last then
1676 If_Stmt := Prag;
1677 else
1678 If_Stmt :=
1679 Make_If_Statement (Loc,
1680 Condition =>
1681 Make_Op_Ne (Loc,
1682 Left_Opnd => New_Occurrence_Of (Curr_Id, Loc),
1683 Right_Opnd => New_Occurrence_Of (Old_Id, Loc)),
1684 Then_Statements => New_List (Prag));
1685 end if;
1686
1687 -- Generate:
1688 -- else
1689 -- <Prag>;
1690 -- end if;
1691
1692 elsif Is_Last then
1693 Set_Else_Statements (If_Stmt, New_List (Prag));
1694
1695 -- Generate:
1696 -- elsif Curr /= Old then
1697 -- <Prag>;
1698
1699 else
1700 if Elsif_Parts (If_Stmt) = No_List then
1701 Set_Elsif_Parts (If_Stmt, New_List);
1702 end if;
1703
1704 Append_To (Elsif_Parts (If_Stmt),
1705 Make_Elsif_Part (Loc,
1706 Condition =>
1707 Make_Op_Ne (Loc,
1708 Left_Opnd => New_Occurrence_Of (Curr_Id, Loc),
1709 Right_Opnd => New_Occurrence_Of (Old_Id, Loc)),
1710 Then_Statements => New_List (Prag)));
1711 end if;
1712 end Process_Variant;
1713
1714 -- Start of processing for Expand_Pragma_Loop_Variant
1715
1716 begin
1717 -- If pragma is not enabled, rewrite as Null statement. If pragma is
1718 -- disabled, it has already been rewritten as a Null statement.
1719
1720 if Is_Ignored (N) then
1721 Rewrite (N, Make_Null_Statement (Loc));
1722 Analyze (N);
1723 return;
1724 end if;
1725
1726 -- Locate the enclosing loop for which this assertion applies. In the
1727 -- case of Ada 2012 array iteration, we might be dealing with nested
1728 -- loops. Only the outermost loop has an identifier.
1729
1730 Loop_Stmt := N;
1731 while Present (Loop_Stmt) loop
1732 if Nkind (Loop_Stmt) = N_Loop_Statement
1733 and then Present (Identifier (Loop_Stmt))
1734 then
1735 exit;
1736 end if;
1737
1738 Loop_Stmt := Parent (Loop_Stmt);
1739 end loop;
1740
1741 Loop_Scop := Entity (Identifier (Loop_Stmt));
1742
1743 -- Create the circuitry which verifies individual variants
1744
1745 Variant := First (Pragma_Argument_Associations (N));
1746 while Present (Variant) loop
1747 Process_Variant (Variant, Is_Last => Variant = Last_Var);
1748
1749 Next (Variant);
1750 end loop;
1751
1752 -- Construct the segment which stores the old values of all expressions.
1753 -- Generate:
1754 -- if Flag then
1755 -- <Old_Assign>
1756 -- end if;
1757
1758 Insert_Action (N,
1759 Make_If_Statement (Loc,
1760 Condition => New_Occurrence_Of (Flag_Id, Loc),
1761 Then_Statements => Old_Assign));
1762
1763 -- Update the values of all expressions
1764
1765 Insert_Actions (N, Curr_Assign);
1766
1767 -- Add the assertion circuitry to test all changes in expressions.
1768 -- Generate:
1769 -- if Flag then
1770 -- <If_Stmt>
1771 -- else
1772 -- Flag := True;
1773 -- end if;
1774
1775 Insert_Action (N,
1776 Make_If_Statement (Loc,
1777 Condition => New_Occurrence_Of (Flag_Id, Loc),
1778 Then_Statements => New_List (If_Stmt),
1779 Else_Statements => New_List (
1780 Make_Assignment_Statement (Loc,
1781 Name => New_Occurrence_Of (Flag_Id, Loc),
1782 Expression => New_Occurrence_Of (Standard_True, Loc)))));
1783
1784 -- Note: the pragma has been completely transformed into a sequence of
1785 -- corresponding declarations and statements. We leave it in the tree
1786 -- for documentation purposes. It will be ignored by the backend.
1787
1788 end Expand_Pragma_Loop_Variant;
1789
1790 --------------------------------
1791 -- Expand_Pragma_Psect_Object --
1792 --------------------------------
1793
1794 -- Convert to Common_Object, and expand the resulting pragma
1795
1796 procedure Expand_Pragma_Psect_Object (N : Node_Id)
1797 renames Expand_Pragma_Common_Object;
1798
1799 -------------------------------------
1800 -- Expand_Pragma_Relative_Deadline --
1801 -------------------------------------
1802
1803 procedure Expand_Pragma_Relative_Deadline (N : Node_Id) is
1804 P : constant Node_Id := Parent (N);
1805 Loc : constant Source_Ptr := Sloc (N);
1806
1807 begin
1808 -- Expand the pragma only in the case of the main subprogram. For tasks
1809 -- the expansion is done in exp_ch9. Generate a call to Set_Deadline
1810 -- at Clock plus the relative deadline specified in the pragma. Time
1811 -- values are translated into Duration to allow for non-private
1812 -- addition operation.
1813
1814 if Nkind (P) = N_Subprogram_Body then
1815 Rewrite
1816 (N,
1817 Make_Procedure_Call_Statement (Loc,
1818 Name => New_Occurrence_Of (RTE (RE_Set_Deadline), Loc),
1819 Parameter_Associations => New_List (
1820 Unchecked_Convert_To (RTE (RO_RT_Time),
1821 Make_Op_Add (Loc,
1822 Left_Opnd =>
1823 Make_Function_Call (Loc,
1824 New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc),
1825 New_List (Make_Function_Call (Loc,
1826 New_Occurrence_Of (RTE (RE_Clock), Loc)))),
1827 Right_Opnd =>
1828 Unchecked_Convert_To (Standard_Duration, Arg1 (N)))))));
1829
1830 Analyze (N);
1831 end if;
1832 end Expand_Pragma_Relative_Deadline;
1833
1834 end Exp_Prag;
Mirror of the offical gcc git repository hosted at gcc.gnu.org