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