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