1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Casing
; use Casing
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Errout
; use Errout
;
31 with Exp_Ch11
; use Exp_Ch11
;
32 with Exp_Util
; use Exp_Util
;
33 with Expander
; use Expander
;
34 with Namet
; use Namet
;
35 with Nlists
; use Nlists
;
36 with Nmake
; use Nmake
;
38 with Restrict
; use Restrict
;
39 with Rident
; use Rident
;
40 with Rtsfind
; use Rtsfind
;
42 with Sem_Ch8
; use Sem_Ch8
;
43 with Sem_Res
; use Sem_Res
;
44 with Sem_Util
; use Sem_Util
;
45 with Sinfo
; use Sinfo
;
46 with Sinput
; use Sinput
;
47 with Snames
; use Snames
;
48 with Stringt
; use Stringt
;
49 with Stand
; use Stand
;
50 with Targparm
; use Targparm
;
51 with Tbuild
; use Tbuild
;
52 with Uintp
; use Uintp
;
54 package body Exp_Prag
is
56 -----------------------
57 -- Local Subprograms --
58 -----------------------
60 function Arg1
(N
: Node_Id
) return Node_Id
;
61 function Arg2
(N
: Node_Id
) return Node_Id
;
62 function Arg3
(N
: Node_Id
) return Node_Id
;
63 -- Obtain specified pragma argument expression
65 procedure Expand_Pragma_Abort_Defer
(N
: Node_Id
);
66 procedure Expand_Pragma_Check
(N
: Node_Id
);
67 procedure Expand_Pragma_Common_Object
(N
: Node_Id
);
68 procedure Expand_Pragma_Import_Or_Interface
(N
: Node_Id
);
69 procedure Expand_Pragma_Import_Export_Exception
(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
);
80 function Arg1
(N
: Node_Id
) return Node_Id
is
81 Arg
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
84 and then Nkind
(Arg
) = N_Pragma_Argument_Association
86 return Expression
(Arg
);
96 function Arg2
(N
: Node_Id
) return Node_Id
is
97 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
105 Arg
: constant Node_Id
:= Next
(Arg1
);
108 and then Nkind
(Arg
) = N_Pragma_Argument_Association
110 return Expression
(Arg
);
122 function Arg3
(N
: Node_Id
) return Node_Id
is
123 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
131 Arg
: Node_Id
:= Next
(Arg1
);
140 and then Nkind
(Arg
) = N_Pragma_Argument_Association
142 return Expression
(Arg
);
151 ---------------------
152 -- Expand_N_Pragma --
153 ---------------------
155 procedure Expand_N_Pragma
(N
: Node_Id
) is
156 Pname
: constant Name_Id
:= Pragma_Name
(N
);
159 -- Note: we may have a pragma whose Pragma_Identifier field is not a
160 -- recognized pragma, and we must ignore it at this stage.
162 if Is_Pragma_Name
(Pname
) then
163 case Get_Pragma_Id
(Pname
) is
165 -- Pragmas requiring special expander action
167 when Pragma_Abort_Defer
=>
168 Expand_Pragma_Abort_Defer
(N
);
171 Expand_Pragma_Check
(N
);
173 when Pragma_Common_Object
=>
174 Expand_Pragma_Common_Object
(N
);
176 when Pragma_Export_Exception
=>
177 Expand_Pragma_Import_Export_Exception
(N
);
179 when Pragma_Import
=>
180 Expand_Pragma_Import_Or_Interface
(N
);
182 when Pragma_Import_Exception
=>
183 Expand_Pragma_Import_Export_Exception
(N
);
185 when Pragma_Inspection_Point
=>
186 Expand_Pragma_Inspection_Point
(N
);
188 when Pragma_Interface
=>
189 Expand_Pragma_Import_Or_Interface
(N
);
191 when Pragma_Interrupt_Priority
=>
192 Expand_Pragma_Interrupt_Priority
(N
);
194 when Pragma_Loop_Variant
=>
195 Expand_Pragma_Loop_Variant
(N
);
197 when Pragma_Psect_Object
=>
198 Expand_Pragma_Psect_Object
(N
);
200 when Pragma_Relative_Deadline
=>
201 Expand_Pragma_Relative_Deadline
(N
);
203 -- All other pragmas need no expander action
211 -------------------------------
212 -- Expand_Pragma_Abort_Defer --
213 -------------------------------
215 -- An Abort_Defer pragma appears as the first statement in a handled
216 -- statement sequence (right after the begin). It defers aborts for
217 -- the entire statement sequence, but not for any declarations or
218 -- handlers (if any) associated with this statement sequence.
220 -- The transformation is to transform
222 -- pragma Abort_Defer;
231 -- when all others =>
232 -- Abort_Undefer.all;
235 -- Abort_Undefer_Direct;
238 procedure Expand_Pragma_Abort_Defer
(N
: Node_Id
) is
239 Loc
: constant Source_Ptr
:= Sloc
(N
);
243 Blk
: constant Entity_Id
:=
244 New_Internal_Entity
(E_Block
, Current_Scope
, Sloc
(N
), 'B');
247 Stms
:= New_List
(Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
250 Stm
:= Remove_Next
(N
);
256 Make_Handled_Sequence_Of_Statements
(Loc
,
259 New_Occurrence_Of
(RTE
(RE_Abort_Undefer_Direct
), Loc
));
262 Make_Block_Statement
(Loc
,
263 Handled_Statement_Sequence
=> HSS
));
265 Set_Scope
(Blk
, Current_Scope
);
266 Set_Etype
(Blk
, Standard_Void_Type
);
267 Set_Identifier
(N
, New_Occurrence_Of
(Blk
, Sloc
(N
)));
268 Expand_At_End_Handler
(HSS
, Blk
);
270 end Expand_Pragma_Abort_Defer
;
272 --------------------------
273 -- Expand_Pragma_Check --
274 --------------------------
276 procedure Expand_Pragma_Check
(N
: Node_Id
) is
277 Loc
: constant Source_Ptr
:= Sloc
(N
);
278 -- Location of the pragma node. Note: it is important to use this
279 -- location (and not the location of the expression) for the generated
280 -- statements, otherwise the implicit return statement in the body
281 -- of a pre/postcondition subprogram may inherit the source location
282 -- of part of the expression, which causes confusing debug information
283 -- to be generated, which interferes with coverage analysis tools.
285 Cond
: constant Node_Id
:= Arg2
(N
);
286 Nam
: constant Name_Id
:= Chars
(Arg1
(N
));
290 -- We already know that this check is enabled, because otherwise the
291 -- semantic pass dealt with rewriting the assertion (see Sem_Prag)
293 -- Since this check is enabled, we rewrite the pragma into a
294 -- corresponding if statement, and then analyze the statement
296 -- The normal case expansion transforms:
298 -- pragma Check (name, condition [,message]);
302 -- if not condition then
303 -- System.Assertions.Raise_Assert_Failure (Str);
306 -- where Str is the message if one is present, or the default of
307 -- name failed at file:line if no message is given (the "name failed
308 -- at" is omitted for name = Assertion, since it is redundant, given
309 -- that the name of the exception is Assert_Failure.)
311 -- An alternative expansion is used when the No_Exception_Propagation
312 -- restriction is active and there is a local Assert_Failure handler.
313 -- This is not a common combination of circumstances, but it occurs in
314 -- the context of Aunit and the zero footprint profile. In this case we
317 -- if not condition then
318 -- raise Assert_Failure;
321 -- This will then be transformed into a goto, and the local handler will
322 -- be able to handle the assert error (which would not be the case if a
323 -- call is made to the Raise_Assert_Failure procedure).
325 -- We also generate the direct raise if the Suppress_Exception_Locations
326 -- is active, since we don't want to generate messages in this case.
328 -- Note that the reason we do not always generate a direct raise is that
329 -- the form in which the procedure is called allows for more efficient
330 -- breakpointing of assertion errors.
332 -- Generate the appropriate if statement. Note that we consider this to
333 -- be an explicit conditional in the source, not an implicit if, so we
334 -- do not call Make_Implicit_If_Statement.
336 -- Case where we generate a direct raise
338 if ((Debug_Flag_Dot_G
339 or else Restriction_Active
(No_Exception_Propagation
))
340 and then Present
(Find_Local_Handler
(RTE
(RE_Assert_Failure
), N
)))
341 or else (Opt
.Exception_Locations_Suppressed
and then No
(Arg3
(N
)))
344 Make_If_Statement
(Loc
,
348 Then_Statements
=> New_List
(
349 Make_Raise_Statement
(Loc
,
351 New_Reference_To
(RTE
(RE_Assert_Failure
), Loc
)))));
353 -- Case where we call the procedure
356 -- If we have a message given, use it
358 if Present
(Arg3
(N
)) then
359 Msg
:= Get_Pragma_Arg
(Arg3
(N
));
361 -- Here we have no string, so prepare one
365 Msg_Loc
: constant String :=
366 Build_Location_String
(Sloc
(First_Node
(Cond
)));
367 -- Source location used in the case of a failed assertion:
368 -- point to the failing condition, not Loc. Note that the
369 -- source location of the expression is not usually the best
370 -- choice here. For example, it gets located on the last AND
371 -- keyword in a chain of boolean expressiond AND'ed together.
372 -- It is best to put the message on the first character of the
373 -- condition, which is the effect of the First_Node call here.
378 -- For Assert, we just use the location
380 if Nam
= Name_Assert
then
383 -- For predicate, we generate the string "predicate failed
384 -- at yyy". We prefer all lower case for predicate.
386 elsif Nam
= Name_Predicate
then
387 Add_Str_To_Name_Buffer
("predicate failed at ");
389 -- For special case of Precondition/Postcondition the string is
390 -- "failed xx from yy" where xx is precondition/postcondition
391 -- in all lower case. The reason for this different wording is
392 -- that the failure is not at the point of occurrence of the
393 -- pragma, unlike the other Check cases.
395 elsif Nam_In
(Nam
, Name_Precondition
, Name_Postcondition
) then
396 Get_Name_String
(Nam
);
397 Insert_Str_In_Name_Buffer
("failed ", 1);
398 Add_Str_To_Name_Buffer
(" from ");
400 -- For all other checks, the string is "xxx failed at yyy"
401 -- where xxx is the check name with current source file casing.
404 Get_Name_String
(Nam
);
405 Set_Casing
(Identifier_Casing
(Current_Source_File
));
406 Add_Str_To_Name_Buffer
(" failed at ");
409 -- In all cases, add location string
411 Add_Str_To_Name_Buffer
(Msg_Loc
);
415 Msg
:= Make_String_Literal
(Loc
, Name_Buffer
(1 .. Name_Len
));
419 -- Now rewrite as an if statement
422 Make_If_Statement
(Loc
,
426 Then_Statements
=> New_List
(
427 Make_Procedure_Call_Statement
(Loc
,
429 New_Reference_To
(RTE
(RE_Raise_Assert_Failure
), Loc
),
430 Parameter_Associations
=> New_List
(Relocate_Node
(Msg
))))));
435 -- If new condition is always false, give a warning
437 if Warn_On_Assertion_Failure
438 and then Nkind
(N
) = N_Procedure_Call_Statement
439 and then Is_RTE
(Entity
(Name
(N
)), RE_Raise_Assert_Failure
)
441 -- If original condition was a Standard.False, we assume that this is
442 -- indeed intended to raise assert error and no warning is required.
444 if Is_Entity_Name
(Original_Node
(Cond
))
445 and then Entity
(Original_Node
(Cond
)) = Standard_False
449 elsif Nam
= Name_Assert
then
450 Error_Msg_N
("?A?assertion will fail at run time", N
);
453 Error_Msg_N
("?A?check will fail at run time", N
);
456 end Expand_Pragma_Check
;
458 ---------------------------------
459 -- Expand_Pragma_Common_Object --
460 ---------------------------------
462 -- Use a machine attribute to replicate semantic effect in DEC Ada
464 -- pragma Machine_Attribute (intern_name, "common_object", extern_name);
466 -- For now we do nothing with the size attribute ???
468 -- Note: Psect_Object shares this processing
470 procedure Expand_Pragma_Common_Object
(N
: Node_Id
) is
471 Loc
: constant Source_Ptr
:= Sloc
(N
);
473 Internal
: constant Node_Id
:= Arg1
(N
);
474 External
: constant Node_Id
:= Arg2
(N
);
477 -- Psect value upper cased as string literal
479 Iloc
: constant Source_Ptr
:= Sloc
(Internal
);
480 Eloc
: constant Source_Ptr
:= Sloc
(External
);
484 -- Acquire Psect value and fold to upper case
486 if Present
(External
) then
487 if Nkind
(External
) = N_String_Literal
then
488 String_To_Name_Buffer
(Strval
(External
));
490 Get_Name_String
(Chars
(External
));
496 Make_String_Literal
(Eloc
,
497 Strval
=> String_From_Name_Buffer
);
500 Get_Name_String
(Chars
(Internal
));
503 Make_String_Literal
(Iloc
,
504 Strval
=> String_From_Name_Buffer
);
507 Ploc
:= Sloc
(Psect
);
511 Insert_After_And_Analyze
(N
,
513 Chars
=> Name_Machine_Attribute
,
514 Pragma_Argument_Associations
=> New_List
(
515 Make_Pragma_Argument_Association
(Iloc
,
516 Expression
=> New_Copy_Tree
(Internal
)),
517 Make_Pragma_Argument_Association
(Eloc
,
519 Make_String_Literal
(Sloc
=> Ploc
,
520 Strval
=> "common_object")),
521 Make_Pragma_Argument_Association
(Ploc
,
522 Expression
=> New_Copy_Tree
(Psect
)))));
524 end Expand_Pragma_Common_Object
;
526 ---------------------------------------
527 -- Expand_Pragma_Import_Or_Interface --
528 ---------------------------------------
530 -- When applied to a variable, the default initialization must not be done.
531 -- As it is already done when the pragma is found, we just get rid of the
532 -- call the initialization procedure which followed the object declaration.
533 -- The call is inserted after the declaration, but validity checks may
534 -- also have been inserted and the initialization call does not necessarily
535 -- appear immediately after the object declaration.
537 -- We can't use the freezing mechanism for this purpose, since we have to
538 -- elaborate the initialization expression when it is first seen (i.e. this
539 -- elaboration cannot be deferred to the freeze point).
541 procedure Expand_Pragma_Import_Or_Interface
(N
: Node_Id
) is
546 Def_Id
:= Entity
(Arg2
(N
));
547 if Ekind
(Def_Id
) = E_Variable
then
549 -- Find and remove generated initialization call for object, if any
551 Init_Call
:= Remove_Init_Call
(Def_Id
, Rep_Clause
=> N
);
553 -- Any default initialization expression should be removed (e.g.,
554 -- null defaults for access objects, zero initialization of packed
555 -- bit arrays). Imported objects aren't allowed to have explicit
556 -- initialization, so the expression must have been generated by
559 if No
(Init_Call
) and then Present
(Expression
(Parent
(Def_Id
))) then
560 Set_Expression
(Parent
(Def_Id
), Empty
);
563 end Expand_Pragma_Import_Or_Interface
;
565 -------------------------------------------
566 -- Expand_Pragma_Import_Export_Exception --
567 -------------------------------------------
569 -- For a VMS exception fix up the language field with "VMS"
570 -- instead of "Ada" (gigi needs this), create a constant that will be the
571 -- value of the VMS condition code and stuff the Interface_Name field
572 -- with the unexpanded name of the exception (if not already set).
573 -- For a Ada exception, just stuff the Interface_Name field
574 -- with the unexpanded name of the exception (if not already set).
576 procedure Expand_Pragma_Import_Export_Exception
(N
: Node_Id
) is
578 -- This pragma is only effective on OpenVMS systems, it was ignored
579 -- on non-VMS systems, and we need to ignore it here as well.
581 if not OpenVMS_On_Target
then
586 Id
: constant Entity_Id
:= Entity
(Arg1
(N
));
587 Call
: constant Node_Id
:= Register_Exception_Call
(Id
);
588 Loc
: constant Source_Ptr
:= Sloc
(N
);
591 if Present
(Call
) then
593 Excep_Internal
: constant Node_Id
:= Make_Temporary
(Loc
, 'V');
594 Export_Pragma
: Node_Id
;
595 Excep_Alias
: Node_Id
;
596 Excep_Object
: Node_Id
;
597 Excep_Image
: String_Id
;
603 if Present
(Interface_Name
(Id
)) then
604 Excep_Image
:= Strval
(Interface_Name
(Id
));
606 Get_Name_String
(Chars
(Id
));
608 Excep_Image
:= String_From_Name_Buffer
;
611 Exdata
:= Component_Associations
(Expression
(Parent
(Id
)));
613 if Is_VMS_Exception
(Id
) then
614 Lang_Char
:= Next
(First
(Exdata
));
616 -- Change the one-character language designator to 'V'
618 Rewrite
(Expression
(Lang_Char
),
619 Make_Character_Literal
(Loc
,
621 Char_Literal_Value
=>
622 UI_From_Int
(Character'Pos ('V'))));
623 Analyze
(Expression
(Lang_Char
));
625 if Exception_Code
(Id
) /= No_Uint
then
627 Make_Integer_Literal
(Loc
,
628 Intval
=> Exception_Code
(Id
));
631 Make_Object_Declaration
(Loc
,
632 Defining_Identifier
=> Excep_Internal
,
634 New_Reference_To
(RTE
(RE_Exception_Code
), Loc
));
636 Insert_Action
(N
, Excep_Object
);
637 Analyze
(Excep_Object
);
641 (UI_To_Int
(Exception_Code
(Id
)) / 8 * 8);
645 Chars
=> Name_Linker_Alias
,
646 Pragma_Argument_Associations
=> New_List
(
647 Make_Pragma_Argument_Association
(Loc
,
649 New_Reference_To
(Excep_Internal
, Loc
)),
651 Make_Pragma_Argument_Association
(Loc
,
653 Make_String_Literal
(Loc
, End_String
))));
655 Insert_Action
(N
, Excep_Alias
);
656 Analyze
(Excep_Alias
);
660 Chars
=> Name_Export
,
661 Pragma_Argument_Associations
=> New_List
(
662 Make_Pragma_Argument_Association
(Loc
,
663 Expression
=> Make_Identifier
(Loc
, Name_C
)),
665 Make_Pragma_Argument_Association
(Loc
,
667 New_Reference_To
(Excep_Internal
, Loc
)),
669 Make_Pragma_Argument_Association
(Loc
,
671 Make_String_Literal
(Loc
, Excep_Image
)),
673 Make_Pragma_Argument_Association
(Loc
,
675 Make_String_Literal
(Loc
, Excep_Image
))));
677 Insert_Action
(N
, Export_Pragma
);
678 Analyze
(Export_Pragma
);
682 Unchecked_Convert_To
(RTE
(RE_Exception_Code
),
683 Make_Function_Call
(Loc
,
685 New_Reference_To
(RTE
(RE_Import_Value
), Loc
),
686 Parameter_Associations
=> New_List
687 (Make_String_Literal
(Loc
,
688 Strval
=> Excep_Image
))));
692 Make_Procedure_Call_Statement
(Loc
,
693 Name
=> New_Reference_To
694 (RTE
(RE_Register_VMS_Exception
), Loc
),
695 Parameter_Associations
=> New_List
(
697 Unchecked_Convert_To
(RTE
(RE_Exception_Data_Ptr
),
698 Make_Attribute_Reference
(Loc
,
699 Prefix
=> New_Occurrence_Of
(Id
, Loc
),
700 Attribute_Name
=> Name_Unrestricted_Access
)))));
702 Analyze_And_Resolve
(Code
, RTE
(RE_Exception_Code
));
706 if No
(Interface_Name
(Id
)) then
707 Set_Interface_Name
(Id
,
710 Strval
=> Excep_Image
));
715 end Expand_Pragma_Import_Export_Exception
;
717 ------------------------------------
718 -- Expand_Pragma_Inspection_Point --
719 ------------------------------------
721 -- If no argument is given, then we supply a default argument list that
722 -- includes all objects declared at the source level in all subprograms
723 -- that enclose the inspection point pragma.
725 procedure Expand_Pragma_Inspection_Point
(N
: Node_Id
) is
726 Loc
: constant Source_Ptr
:= Sloc
(N
);
733 if No
(Pragma_Argument_Associations
(N
)) then
737 while S
/= Standard_Standard
loop
738 E
:= First_Entity
(S
);
739 while Present
(E
) loop
740 if Comes_From_Source
(E
)
741 and then Is_Object
(E
)
742 and then not Is_Entry_Formal
(E
)
743 and then Ekind
(E
) /= E_Component
744 and then Ekind
(E
) /= E_Discriminant
745 and then Ekind
(E
) /= E_Generic_In_Parameter
746 and then Ekind
(E
) /= E_Generic_In_Out_Parameter
749 Make_Pragma_Argument_Association
(Loc
,
750 Expression
=> New_Occurrence_Of
(E
, Loc
)));
759 Set_Pragma_Argument_Associations
(N
, A
);
762 -- Expand the arguments of the pragma. Expanding an entity reference
763 -- is a noop, except in a protected operation, where a reference may
764 -- have to be transformed into a reference to the corresponding prival.
765 -- Are there other pragmas that may require this ???
767 Assoc
:= First
(Pragma_Argument_Associations
(N
));
769 while Present
(Assoc
) loop
770 Expand
(Expression
(Assoc
));
773 end Expand_Pragma_Inspection_Point
;
775 --------------------------------------
776 -- Expand_Pragma_Interrupt_Priority --
777 --------------------------------------
779 -- Supply default argument if none exists (System.Interrupt_Priority'Last)
781 procedure Expand_Pragma_Interrupt_Priority
(N
: Node_Id
) is
782 Loc
: constant Source_Ptr
:= Sloc
(N
);
785 if No
(Pragma_Argument_Associations
(N
)) then
786 Set_Pragma_Argument_Associations
(N
, New_List
(
787 Make_Pragma_Argument_Association
(Loc
,
789 Make_Attribute_Reference
(Loc
,
791 New_Occurrence_Of
(RTE
(RE_Interrupt_Priority
), Loc
),
792 Attribute_Name
=> Name_Last
))));
794 end Expand_Pragma_Interrupt_Priority
;
796 --------------------------------
797 -- Expand_Pragma_Loop_Variant --
798 --------------------------------
800 -- Pragma Loop_Variant is expanded in the following manner:
804 -- for | while ... loop
805 -- <preceding source statements>
806 -- pragma Loop_Variant
807 -- (Increases => Incr_Expr,
808 -- Decreases => Decr_Expr);
809 -- <succeeding source statements>
814 -- Curr_1 : <type of Incr_Expr>;
815 -- Curr_2 : <type of Decr_Expr>;
816 -- Old_1 : <type of Incr_Expr>;
817 -- Old_2 : <type of Decr_Expr>;
818 -- Flag : Boolean := False;
820 -- for | while ... loop
821 -- <preceding source statements>
828 -- Curr_1 := <Incr_Expr>;
829 -- Curr_2 := <Decr_Expr>;
832 -- if Curr_1 /= Old_1 then
833 -- pragma Check (Loop_Variant, Curr_1 > Old_1);
835 -- pragma Check (Loop_Variant, Curr_2 < Old_2);
841 -- <succeeding source statements>
844 procedure Expand_Pragma_Loop_Variant
(N
: Node_Id
) is
845 Loc
: constant Source_Ptr
:= Sloc
(N
);
847 Last_Var
: constant Node_Id
:= Last
(Pragma_Argument_Associations
(N
));
849 Curr_Assign
: List_Id
:= No_List
;
850 Flag_Id
: Entity_Id
:= Empty
;
851 If_Stmt
: Node_Id
:= Empty
;
852 Old_Assign
: List_Id
:= No_List
;
853 Loop_Scop
: Entity_Id
;
857 procedure Process_Variant
(Variant
: Node_Id
; Is_Last
: Boolean);
858 -- Process a single increasing / decreasing termination variant. Flag
859 -- Is_Last should be set when processing the last variant.
861 ---------------------
862 -- Process_Variant --
863 ---------------------
865 procedure Process_Variant
(Variant
: Node_Id
; Is_Last
: Boolean) is
869 Old_Val
: Node_Id
) return Node_Id
;
870 -- Generate a comparison between Curr_Val and Old_Val depending on
871 -- the change mode (Increases / Decreases) of the variant.
880 Old_Val
: Node_Id
) return Node_Id
883 if Chars
(Variant
) = Name_Increases
then
884 return Make_Op_Gt
(Loc
, Curr_Val
, Old_Val
);
885 else pragma Assert
(Chars
(Variant
) = Name_Decreases
);
886 return Make_Op_Lt
(Loc
, Curr_Val
, Old_Val
);
892 Expr
: constant Node_Id
:= Expression
(Variant
);
893 Expr_Typ
: constant Entity_Id
:= Etype
(Expr
);
894 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
895 Loop_Loc
: constant Source_Ptr
:= Sloc
(Loop_Stmt
);
900 -- Start of processing for Process_Variant
903 -- All temporaries generated in this routine must be inserted before
904 -- the related loop statement. Ensure that the proper scope is on the
905 -- stack when analyzing the temporaries. Note that we also use the
906 -- Sloc of the related loop.
908 Push_Scope
(Scope
(Loop_Scop
));
910 -- Step 1: Create the declaration of the flag which controls the
911 -- behavior of the assertion on the first iteration of the loop.
916 -- Flag : Boolean := False;
918 Flag_Id
:= Make_Temporary
(Loop_Loc
, 'F');
920 Insert_Action
(Loop_Stmt
,
921 Make_Object_Declaration
(Loop_Loc
,
922 Defining_Identifier
=> Flag_Id
,
924 New_Reference_To
(Standard_Boolean
, Loop_Loc
),
926 New_Reference_To
(Standard_False
, Loop_Loc
)));
928 -- Prevent an unwanted optimization where the Current_Value of
929 -- the flag eliminates the if statement which stores the variant
930 -- values coming from the previous iteration.
932 -- Flag : Boolean := False;
934 -- if Flag then -- condition rewritten to False
935 -- Old_N := Curr_N; -- and if statement eliminated
941 Set_Current_Value
(Flag_Id
, Empty
);
944 -- Step 2: Create the temporaries which store the old and current
945 -- values of the associated expression.
948 -- Curr : <type of Expr>;
950 Curr_Id
:= Make_Temporary
(Loc
, 'C');
952 Insert_Action
(Loop_Stmt
,
953 Make_Object_Declaration
(Loop_Loc
,
954 Defining_Identifier
=> Curr_Id
,
955 Object_Definition
=> New_Reference_To
(Expr_Typ
, Loop_Loc
)));
958 -- Old : <type of Expr>;
960 Old_Id
:= Make_Temporary
(Loc
, 'P');
962 Insert_Action
(Loop_Stmt
,
963 Make_Object_Declaration
(Loop_Loc
,
964 Defining_Identifier
=> Old_Id
,
965 Object_Definition
=> New_Reference_To
(Expr_Typ
, Loop_Loc
)));
967 -- Restore original scope after all temporaries have been analyzed
971 -- Step 3: Store value of the expression from the previous iteration
973 if No
(Old_Assign
) then
974 Old_Assign
:= New_List
;
980 Append_To
(Old_Assign
,
981 Make_Assignment_Statement
(Loc
,
982 Name
=> New_Reference_To
(Old_Id
, Loc
),
983 Expression
=> New_Reference_To
(Curr_Id
, Loc
)));
985 -- Step 4: Store the current value of the expression
987 if No
(Curr_Assign
) then
988 Curr_Assign
:= New_List
;
994 Append_To
(Curr_Assign
,
995 Make_Assignment_Statement
(Loc
,
996 Name
=> New_Reference_To
(Curr_Id
, Loc
),
997 Expression
=> Relocate_Node
(Expr
)));
999 -- Step 5: Create corresponding assertion to verify change of value
1002 -- pragma Check (Loop_Variant, Curr <|> Old);
1006 Chars
=> Name_Check
,
1007 Pragma_Argument_Associations
=> New_List
(
1008 Make_Pragma_Argument_Association
(Loc
,
1009 Expression
=> Make_Identifier
(Loc
, Name_Loop_Variant
)),
1010 Make_Pragma_Argument_Association
(Loc
,
1013 Curr_Val
=> New_Reference_To
(Curr_Id
, Loc
),
1014 Old_Val
=> New_Reference_To
(Old_Id
, Loc
)))));
1017 -- if Curr /= Old then
1020 if No
(If_Stmt
) then
1022 -- When there is just one termination variant, do not compare the
1023 -- old and current value for equality, just check the pragma.
1029 Make_If_Statement
(Loc
,
1032 Left_Opnd
=> New_Reference_To
(Curr_Id
, Loc
),
1033 Right_Opnd
=> New_Reference_To
(Old_Id
, Loc
)),
1034 Then_Statements
=> New_List
(Prag
));
1043 Set_Else_Statements
(If_Stmt
, New_List
(Prag
));
1046 -- elsif Curr /= Old then
1050 if Elsif_Parts
(If_Stmt
) = No_List
then
1051 Set_Elsif_Parts
(If_Stmt
, New_List
);
1054 Append_To
(Elsif_Parts
(If_Stmt
),
1055 Make_Elsif_Part
(Loc
,
1058 Left_Opnd
=> New_Reference_To
(Curr_Id
, Loc
),
1059 Right_Opnd
=> New_Reference_To
(Old_Id
, Loc
)),
1060 Then_Statements
=> New_List
(Prag
)));
1062 end Process_Variant
;
1064 -- Start of processing for Expand_Pragma_Loop_Variant
1067 -- If pragma is not enabled, rewrite as Null statement. If pragma is
1068 -- disabled, it has already been rewritten as a Null statement.
1070 if Is_Ignored
(N
) then
1071 Rewrite
(N
, Make_Null_Statement
(Loc
));
1076 -- Locate the enclosing loop for which this assertion applies. In the
1077 -- case of Ada 2012 array iteration, we might be dealing with nested
1078 -- loops. Only the outermost loop has an identifier.
1081 while Present
(Loop_Stmt
) loop
1082 if Nkind
(Loop_Stmt
) = N_Loop_Statement
1083 and then Present
(Identifier
(Loop_Stmt
))
1088 Loop_Stmt
:= Parent
(Loop_Stmt
);
1091 Loop_Scop
:= Entity
(Identifier
(Loop_Stmt
));
1093 -- Create the circuitry which verifies individual variants
1095 Variant
:= First
(Pragma_Argument_Associations
(N
));
1096 while Present
(Variant
) loop
1097 Process_Variant
(Variant
, Is_Last
=> Variant
= Last_Var
);
1102 -- Construct the segment which stores the old values of all expressions.
1109 Make_If_Statement
(Loc
,
1110 Condition
=> New_Reference_To
(Flag_Id
, Loc
),
1111 Then_Statements
=> Old_Assign
));
1113 -- Update the values of all expressions
1115 Insert_Actions
(N
, Curr_Assign
);
1117 -- Add the assertion circuitry to test all changes in expressions.
1126 Make_If_Statement
(Loc
,
1127 Condition
=> New_Reference_To
(Flag_Id
, Loc
),
1128 Then_Statements
=> New_List
(If_Stmt
),
1129 Else_Statements
=> New_List
(
1130 Make_Assignment_Statement
(Loc
,
1131 Name
=> New_Reference_To
(Flag_Id
, Loc
),
1132 Expression
=> New_Reference_To
(Standard_True
, Loc
)))));
1134 -- Note: the pragma has been completely transformed into a sequence of
1135 -- corresponding declarations and statements. We leave it in the tree
1136 -- for documentation purposes. It will be ignored by the backend.
1138 end Expand_Pragma_Loop_Variant
;
1140 --------------------------------
1141 -- Expand_Pragma_Psect_Object --
1142 --------------------------------
1144 -- Convert to Common_Object, and expand the resulting pragma
1146 procedure Expand_Pragma_Psect_Object
(N
: Node_Id
)
1147 renames Expand_Pragma_Common_Object
;
1149 -------------------------------------
1150 -- Expand_Pragma_Relative_Deadline --
1151 -------------------------------------
1153 procedure Expand_Pragma_Relative_Deadline
(N
: Node_Id
) is
1154 P
: constant Node_Id
:= Parent
(N
);
1155 Loc
: constant Source_Ptr
:= Sloc
(N
);
1158 -- Expand the pragma only in the case of the main subprogram. For tasks
1159 -- the expansion is done in exp_ch9. Generate a call to Set_Deadline
1160 -- at Clock plus the relative deadline specified in the pragma. Time
1161 -- values are translated into Duration to allow for non-private
1162 -- addition operation.
1164 if Nkind
(P
) = N_Subprogram_Body
then
1167 Make_Procedure_Call_Statement
(Loc
,
1168 Name
=> New_Reference_To
(RTE
(RE_Set_Deadline
), Loc
),
1169 Parameter_Associations
=> New_List
(
1170 Unchecked_Convert_To
(RTE
(RO_RT_Time
),
1173 Make_Function_Call
(Loc
,
1174 New_Reference_To
(RTE
(RO_RT_To_Duration
), Loc
),
1175 New_List
(Make_Function_Call
(Loc
,
1176 New_Reference_To
(RTE
(RE_Clock
), Loc
)))),
1178 Unchecked_Convert_To
(Standard_Duration
, Arg1
(N
)))))));
1182 end Expand_Pragma_Relative_Deadline
;