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