1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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_Res
; use Sem_Res
;
43 with Sem_Util
; use Sem_Util
;
44 with Sinfo
; use Sinfo
;
45 with Sinput
; use Sinput
;
46 with Snames
; use Snames
;
47 with Stringt
; use Stringt
;
48 with Stand
; use Stand
;
49 with Targparm
; use Targparm
;
50 with Tbuild
; use Tbuild
;
51 with Uintp
; use Uintp
;
53 package body Exp_Prag
is
55 -----------------------
56 -- Local Subprograms --
57 -----------------------
59 function Arg1
(N
: Node_Id
) return Node_Id
;
60 function Arg2
(N
: Node_Id
) return Node_Id
;
61 function Arg3
(N
: Node_Id
) return Node_Id
;
62 -- Obtain specified pragma argument expression
64 procedure Expand_Pragma_Abort_Defer
(N
: Node_Id
);
65 procedure Expand_Pragma_Check
(N
: Node_Id
);
66 procedure Expand_Pragma_Common_Object
(N
: Node_Id
);
67 procedure Expand_Pragma_Import_Or_Interface
(N
: Node_Id
);
68 procedure Expand_Pragma_Import_Export_Exception
(N
: Node_Id
);
69 procedure Expand_Pragma_Inspection_Point
(N
: Node_Id
);
70 procedure Expand_Pragma_Interrupt_Priority
(N
: Node_Id
);
71 procedure Expand_Pragma_Psect_Object
(N
: Node_Id
);
72 procedure Expand_Pragma_Relative_Deadline
(N
: Node_Id
);
78 function Arg1
(N
: Node_Id
) return Node_Id
is
79 Arg
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
82 and then Nkind
(Arg
) = N_Pragma_Argument_Association
84 return Expression
(Arg
);
94 function Arg2
(N
: Node_Id
) return Node_Id
is
95 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
103 Arg
: constant Node_Id
:= Next
(Arg1
);
106 and then Nkind
(Arg
) = N_Pragma_Argument_Association
108 return Expression
(Arg
);
120 function Arg3
(N
: Node_Id
) return Node_Id
is
121 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
129 Arg
: Node_Id
:= Next
(Arg1
);
138 and then Nkind
(Arg
) = N_Pragma_Argument_Association
140 return Expression
(Arg
);
149 ---------------------
150 -- Expand_N_Pragma --
151 ---------------------
153 procedure Expand_N_Pragma
(N
: Node_Id
) is
154 Pname
: constant Name_Id
:= Pragma_Name
(N
);
157 -- Note: we may have a pragma whose Pragma_Identifier field is not a
158 -- recognized pragma, and we must ignore it at this stage.
160 if Is_Pragma_Name
(Pname
) then
161 case Get_Pragma_Id
(Pname
) is
163 -- Pragmas requiring special expander action
165 when Pragma_Abort_Defer
=>
166 Expand_Pragma_Abort_Defer
(N
);
169 Expand_Pragma_Check
(N
);
171 when Pragma_Common_Object
=>
172 Expand_Pragma_Common_Object
(N
);
174 when Pragma_Export_Exception
=>
175 Expand_Pragma_Import_Export_Exception
(N
);
177 when Pragma_Import
=>
178 Expand_Pragma_Import_Or_Interface
(N
);
180 when Pragma_Import_Exception
=>
181 Expand_Pragma_Import_Export_Exception
(N
);
183 when Pragma_Inspection_Point
=>
184 Expand_Pragma_Inspection_Point
(N
);
186 when Pragma_Interface
=>
187 Expand_Pragma_Import_Or_Interface
(N
);
189 when Pragma_Interrupt_Priority
=>
190 Expand_Pragma_Interrupt_Priority
(N
);
192 when Pragma_Psect_Object
=>
193 Expand_Pragma_Psect_Object
(N
);
195 when Pragma_Relative_Deadline
=>
196 Expand_Pragma_Relative_Deadline
(N
);
198 -- All other pragmas need no expander action
206 -------------------------------
207 -- Expand_Pragma_Abort_Defer --
208 -------------------------------
210 -- An Abort_Defer pragma appears as the first statement in a handled
211 -- statement sequence (right after the begin). It defers aborts for
212 -- the entire statement sequence, but not for any declarations or
213 -- handlers (if any) associated with this statement sequence.
215 -- The transformation is to transform
217 -- pragma Abort_Defer;
226 -- when all others =>
227 -- Abort_Undefer.all;
230 -- Abort_Undefer_Direct;
233 procedure Expand_Pragma_Abort_Defer
(N
: Node_Id
) is
234 Loc
: constant Source_Ptr
:= Sloc
(N
);
238 Blk
: constant Entity_Id
:=
239 New_Internal_Entity
(E_Block
, Current_Scope
, Sloc
(N
), 'B');
242 Stms
:= New_List
(Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
245 Stm
:= Remove_Next
(N
);
251 Make_Handled_Sequence_Of_Statements
(Loc
,
254 New_Occurrence_Of
(RTE
(RE_Abort_Undefer_Direct
), Loc
));
257 Make_Block_Statement
(Loc
,
258 Handled_Statement_Sequence
=> HSS
));
260 Set_Scope
(Blk
, Current_Scope
);
261 Set_Etype
(Blk
, Standard_Void_Type
);
262 Set_Identifier
(N
, New_Occurrence_Of
(Blk
, Sloc
(N
)));
263 Expand_At_End_Handler
(HSS
, Blk
);
265 end Expand_Pragma_Abort_Defer
;
267 --------------------------
268 -- Expand_Pragma_Check --
269 --------------------------
271 procedure Expand_Pragma_Check
(N
: Node_Id
) is
272 Cond
: constant Node_Id
:= Arg2
(N
);
273 Loc
: constant Source_Ptr
:= Sloc
(Cond
);
274 Nam
: constant Name_Id
:= Chars
(Arg1
(N
));
278 -- We already know that this check is enabled, because otherwise the
279 -- semantic pass dealt with rewriting the assertion (see Sem_Prag)
281 -- Since this check is enabled, we rewrite the pragma into a
282 -- corresponding if statement, and then analyze the statement
284 -- The normal case expansion transforms:
286 -- pragma Check (name, condition [,message]);
290 -- if not condition then
291 -- System.Assertions.Raise_Assert_Failure (Str);
294 -- where Str is the message if one is present, or the default of
295 -- name failed at file:line if no message is given (the "name failed
296 -- at" is omitted for name = Assertion, since it is redundant, given
297 -- that the name of the exception is Assert_Failure.
299 -- An alternative expansion is used when the No_Exception_Propagation
300 -- restriction is active and there is a local Assert_Failure handler.
301 -- This is not a common combination of circumstances, but it occurs in
302 -- the context of Aunit and the zero footprint profile. In this case we
305 -- if not condition then
306 -- raise Assert_Failure;
309 -- This will then be transformed into a goto, and the local handler will
310 -- be able to handle the assert error (which would not be the case if a
311 -- call is made to the Raise_Assert_Failure procedure).
313 -- We also generate the direct raise if the Suppress_Exception_Locations
314 -- is active, since we don't want to generate messages in this case.
316 -- Note that the reason we do not always generate a direct raise is that
317 -- the form in which the procedure is called allows for more efficient
318 -- breakpointing of assertion errors.
320 -- Generate the appropriate if statement. Note that we consider this to
321 -- be an explicit conditional in the source, not an implicit if, so we
322 -- do not call Make_Implicit_If_Statement.
324 -- Case where we generate a direct raise
326 if ((Debug_Flag_Dot_G
327 or else Restriction_Active
(No_Exception_Propagation
))
328 and then Present
(Find_Local_Handler
(RTE
(RE_Assert_Failure
), N
)))
329 or else (Opt
.Exception_Locations_Suppressed
and then No
(Arg3
(N
)))
332 Make_If_Statement
(Loc
,
336 Then_Statements
=> New_List
(
337 Make_Raise_Statement
(Loc
,
339 New_Reference_To
(RTE
(RE_Assert_Failure
), Loc
)))));
341 -- Case where we call the procedure
344 -- If we have a message given, use it
346 if Present
(Arg3
(N
)) then
347 Msg
:= Get_Pragma_Arg
(Arg3
(N
));
349 -- Here we have no string, so prepare one
353 Msg_Loc
: constant String := Build_Location_String
(Loc
);
356 -- For Assert, we just use the location
358 if Nam
= Name_Assertion
then
361 -- For any check except Precondition/Postcondition, the
362 -- string is "xxx failed at yyy" where xxx is the name of
363 -- the check with current source file casing.
365 elsif Nam
/= Name_Precondition
367 Nam
/= Name_Postcondition
369 Get_Name_String
(Nam
);
370 Set_Casing
(Identifier_Casing
(Current_Source_File
));
371 Add_Str_To_Name_Buffer
(" failed at ");
373 -- For special case of Precondition/Postcondition the string is
374 -- "failed xx from yy" where xx is precondition/postcondition
375 -- in all lower case. The reason for this different wording is
376 -- that the failure is not at the point of occurrence of the
377 -- pragma, unlike the other Check cases.
380 Get_Name_String
(Nam
);
381 Insert_Str_In_Name_Buffer
("failed ", 1);
382 Add_Str_To_Name_Buffer
(" from ");
385 -- In all cases, add location string
387 Add_Str_To_Name_Buffer
(Msg_Loc
);
391 Msg
:= Make_String_Literal
(Loc
, Name_Buffer
(1 .. Name_Len
));
395 -- Now rewrite as an if statement
398 Make_If_Statement
(Loc
,
402 Then_Statements
=> New_List
(
403 Make_Procedure_Call_Statement
(Loc
,
405 New_Reference_To
(RTE
(RE_Raise_Assert_Failure
), Loc
),
406 Parameter_Associations
=> New_List
(Relocate_Node
(Msg
))))));
411 -- If new condition is always false, give a warning
413 if Warn_On_Assertion_Failure
414 and then Nkind
(N
) = N_Procedure_Call_Statement
415 and then Is_RTE
(Entity
(Name
(N
)), RE_Raise_Assert_Failure
)
417 -- If original condition was a Standard.False, we assume that this is
418 -- indeed intended to raise assert error and no warning is required.
420 if Is_Entity_Name
(Original_Node
(Cond
))
421 and then Entity
(Original_Node
(Cond
)) = Standard_False
424 elsif Nam
= Name_Assertion
then
425 Error_Msg_N
("?assertion will fail at run time", N
);
427 Error_Msg_N
("?check will fail at run time", N
);
430 end Expand_Pragma_Check
;
432 ---------------------------------
433 -- Expand_Pragma_Common_Object --
434 ---------------------------------
436 -- Use a machine attribute to replicate semantic effect in DEC Ada
438 -- pragma Machine_Attribute (intern_name, "common_object", extern_name);
440 -- For now we do nothing with the size attribute ???
442 -- Note: Psect_Object shares this processing
444 procedure Expand_Pragma_Common_Object
(N
: Node_Id
) is
445 Loc
: constant Source_Ptr
:= Sloc
(N
);
447 Internal
: constant Node_Id
:= Arg1
(N
);
448 External
: constant Node_Id
:= Arg2
(N
);
451 -- Psect value upper cased as string literal
453 Iloc
: constant Source_Ptr
:= Sloc
(Internal
);
454 Eloc
: constant Source_Ptr
:= Sloc
(External
);
458 -- Acquire Psect value and fold to upper case
460 if Present
(External
) then
461 if Nkind
(External
) = N_String_Literal
then
462 String_To_Name_Buffer
(Strval
(External
));
464 Get_Name_String
(Chars
(External
));
470 Make_String_Literal
(Eloc
,
471 Strval
=> String_From_Name_Buffer
);
474 Get_Name_String
(Chars
(Internal
));
477 Make_String_Literal
(Iloc
,
478 Strval
=> String_From_Name_Buffer
);
481 Ploc
:= Sloc
(Psect
);
485 Insert_After_And_Analyze
(N
,
487 Chars
=> Name_Machine_Attribute
,
488 Pragma_Argument_Associations
=> New_List
(
489 Make_Pragma_Argument_Association
(Iloc
,
490 Expression
=> New_Copy_Tree
(Internal
)),
491 Make_Pragma_Argument_Association
(Eloc
,
493 Make_String_Literal
(Sloc
=> Ploc
,
494 Strval
=> "common_object")),
495 Make_Pragma_Argument_Association
(Ploc
,
496 Expression
=> New_Copy_Tree
(Psect
)))));
498 end Expand_Pragma_Common_Object
;
500 ---------------------------------------
501 -- Expand_Pragma_Import_Or_Interface --
502 ---------------------------------------
504 -- When applied to a variable, the default initialization must not be
505 -- done. As it is already done when the pragma is found, we just get rid
506 -- of the call the initialization procedure which followed the object
507 -- declaration. The call is inserted after the declaration, but validity
508 -- checks may also have been inserted and the initialization call does
509 -- not necessarily appear immediately after the object declaration.
511 -- We can't use the freezing mechanism for this purpose, since we
512 -- have to elaborate the initialization expression when it is first
513 -- seen (i.e. this elaboration cannot be deferred to the freeze point).
515 procedure Expand_Pragma_Import_Or_Interface
(N
: Node_Id
) is
516 Def_Id
: constant Entity_Id
:= Entity
(Arg2
(N
));
520 if Ekind
(Def_Id
) = E_Variable
then
522 -- Find generated initialization call for object, if any
524 Init_Call
:= Find_Init_Call
(Def_Id
, Rep_Clause
=> N
);
525 if Present
(Init_Call
) then
529 -- Any default initialization expression should be removed
530 -- (e.g., null defaults for access objects, zero initialization
531 -- of packed bit arrays). Imported objects aren't allowed to
532 -- have explicit initialization, so the expression must have
533 -- been generated by the compiler.
535 if No
(Init_Call
) and then Present
(Expression
(Parent
(Def_Id
))) then
536 Set_Expression
(Parent
(Def_Id
), Empty
);
539 end Expand_Pragma_Import_Or_Interface
;
541 -------------------------------------------
542 -- Expand_Pragma_Import_Export_Exception --
543 -------------------------------------------
545 -- For a VMS exception fix up the language field with "VMS"
546 -- instead of "Ada" (gigi needs this), create a constant that will be the
547 -- value of the VMS condition code and stuff the Interface_Name field
548 -- with the unexpanded name of the exception (if not already set).
549 -- For a Ada exception, just stuff the Interface_Name field
550 -- with the unexpanded name of the exception (if not already set).
552 procedure Expand_Pragma_Import_Export_Exception
(N
: Node_Id
) is
554 -- This pragma is only effective on OpenVMS systems, it was ignored
555 -- on non-VMS systems, and we need to ignore it here as well.
557 if not OpenVMS_On_Target
then
562 Id
: constant Entity_Id
:= Entity
(Arg1
(N
));
563 Call
: constant Node_Id
:= Register_Exception_Call
(Id
);
564 Loc
: constant Source_Ptr
:= Sloc
(N
);
567 if Present
(Call
) then
569 Excep_Internal
: constant Node_Id
:= Make_Temporary
(Loc
, 'V');
570 Export_Pragma
: Node_Id
;
571 Excep_Alias
: Node_Id
;
572 Excep_Object
: Node_Id
;
573 Excep_Image
: String_Id
;
579 if Present
(Interface_Name
(Id
)) then
580 Excep_Image
:= Strval
(Interface_Name
(Id
));
582 Get_Name_String
(Chars
(Id
));
584 Excep_Image
:= String_From_Name_Buffer
;
587 Exdata
:= Component_Associations
(Expression
(Parent
(Id
)));
589 if Is_VMS_Exception
(Id
) then
590 Lang_Char
:= Next
(First
(Exdata
));
592 -- Change the one-character language designator to 'V'
594 Rewrite
(Expression
(Lang_Char
),
595 Make_Character_Literal
(Loc
,
597 Char_Literal_Value
=>
598 UI_From_Int
(Character'Pos ('V'))));
599 Analyze
(Expression
(Lang_Char
));
601 if Exception_Code
(Id
) /= No_Uint
then
603 Make_Integer_Literal
(Loc
,
604 Intval
=> Exception_Code
(Id
));
607 Make_Object_Declaration
(Loc
,
608 Defining_Identifier
=> Excep_Internal
,
610 New_Reference_To
(RTE
(RE_Exception_Code
), Loc
));
612 Insert_Action
(N
, Excep_Object
);
613 Analyze
(Excep_Object
);
617 (UI_To_Int
(Exception_Code
(Id
)) / 8 * 8);
624 (Make_Pragma_Argument_Association
627 New_Reference_To
(Excep_Internal
, Loc
)),
629 Make_Pragma_Argument_Association
634 Strval
=> End_String
))));
636 Insert_Action
(N
, Excep_Alias
);
637 Analyze
(Excep_Alias
);
644 (Make_Pragma_Argument_Association
646 Expression
=> Make_Identifier
(Loc
, Name_C
)),
648 Make_Pragma_Argument_Association
651 New_Reference_To
(Excep_Internal
, Loc
)),
653 Make_Pragma_Argument_Association
658 Strval
=> Excep_Image
)),
660 Make_Pragma_Argument_Association
665 Strval
=> Excep_Image
))));
667 Insert_Action
(N
, Export_Pragma
);
668 Analyze
(Export_Pragma
);
672 Unchecked_Convert_To
(RTE
(RE_Exception_Code
),
673 Make_Function_Call
(Loc
,
675 New_Reference_To
(RTE
(RE_Import_Value
), Loc
),
676 Parameter_Associations
=> New_List
677 (Make_String_Literal
(Loc
,
678 Strval
=> Excep_Image
))));
682 Make_Procedure_Call_Statement
(Loc
,
683 Name
=> New_Reference_To
684 (RTE
(RE_Register_VMS_Exception
), Loc
),
685 Parameter_Associations
=> New_List
(
687 Unchecked_Convert_To
(RTE
(RE_Exception_Data_Ptr
),
688 Make_Attribute_Reference
(Loc
,
689 Prefix
=> New_Occurrence_Of
(Id
, Loc
),
690 Attribute_Name
=> Name_Unrestricted_Access
)))));
692 Analyze_And_Resolve
(Code
, RTE
(RE_Exception_Code
));
696 if No
(Interface_Name
(Id
)) then
697 Set_Interface_Name
(Id
,
700 Strval
=> Excep_Image
));
705 end Expand_Pragma_Import_Export_Exception
;
707 ------------------------------------
708 -- Expand_Pragma_Inspection_Point --
709 ------------------------------------
711 -- If no argument is given, then we supply a default argument list that
712 -- includes all objects declared at the source level in all subprograms
713 -- that enclose the inspection point pragma.
715 procedure Expand_Pragma_Inspection_Point
(N
: Node_Id
) is
716 Loc
: constant Source_Ptr
:= Sloc
(N
);
723 if No
(Pragma_Argument_Associations
(N
)) then
727 while S
/= Standard_Standard
loop
728 E
:= First_Entity
(S
);
729 while Present
(E
) loop
730 if Comes_From_Source
(E
)
731 and then Is_Object
(E
)
732 and then not Is_Entry_Formal
(E
)
733 and then Ekind
(E
) /= E_Component
734 and then Ekind
(E
) /= E_Discriminant
735 and then Ekind
(E
) /= E_Generic_In_Parameter
736 and then Ekind
(E
) /= E_Generic_In_Out_Parameter
739 Make_Pragma_Argument_Association
(Loc
,
740 Expression
=> New_Occurrence_Of
(E
, Loc
)));
749 Set_Pragma_Argument_Associations
(N
, A
);
752 -- Expand the arguments of the pragma. Expanding an entity reference
753 -- is a noop, except in a protected operation, where a reference may
754 -- have to be transformed into a reference to the corresponding prival.
755 -- Are there other pragmas that may require this ???
757 Assoc
:= First
(Pragma_Argument_Associations
(N
));
759 while Present
(Assoc
) loop
760 Expand
(Expression
(Assoc
));
763 end Expand_Pragma_Inspection_Point
;
765 --------------------------------------
766 -- Expand_Pragma_Interrupt_Priority --
767 --------------------------------------
769 -- Supply default argument if none exists (System.Interrupt_Priority'Last)
771 procedure Expand_Pragma_Interrupt_Priority
(N
: Node_Id
) is
772 Loc
: constant Source_Ptr
:= Sloc
(N
);
775 if No
(Pragma_Argument_Associations
(N
)) then
776 Set_Pragma_Argument_Associations
(N
, New_List
(
777 Make_Pragma_Argument_Association
(Loc
,
779 Make_Attribute_Reference
(Loc
,
781 New_Occurrence_Of
(RTE
(RE_Interrupt_Priority
), Loc
),
782 Attribute_Name
=> Name_Last
))));
784 end Expand_Pragma_Interrupt_Priority
;
786 --------------------------------
787 -- Expand_Pragma_Psect_Object --
788 --------------------------------
790 -- Convert to Common_Object, and expand the resulting pragma
792 procedure Expand_Pragma_Psect_Object
(N
: Node_Id
)
793 renames Expand_Pragma_Common_Object
;
795 -------------------------------------
796 -- Expand_Pragma_Relative_Deadline --
797 -------------------------------------
799 procedure Expand_Pragma_Relative_Deadline
(N
: Node_Id
) is
800 P
: constant Node_Id
:= Parent
(N
);
801 Loc
: constant Source_Ptr
:= Sloc
(N
);
804 -- Expand the pragma only in the case of the main subprogram. For tasks
805 -- the expansion is done in exp_ch9. Generate a call to Set_Deadline
806 -- at Clock plus the relative deadline specified in the pragma. Time
807 -- values are translated into Duration to allow for non-private
808 -- addition operation.
810 if Nkind
(P
) = N_Subprogram_Body
then
813 Make_Procedure_Call_Statement
(Loc
,
814 Name
=> New_Reference_To
(RTE
(RE_Set_Deadline
), Loc
),
815 Parameter_Associations
=> New_List
(
816 Unchecked_Convert_To
(RTE
(RO_RT_Time
),
819 Make_Function_Call
(Loc
,
820 New_Reference_To
(RTE
(RO_RT_To_Duration
), Loc
),
821 New_List
(Make_Function_Call
(Loc
,
822 New_Reference_To
(RTE
(RE_Clock
), Loc
)))),
824 Unchecked_Convert_To
(Standard_Duration
, Arg1
(N
)))))));
828 end Expand_Pragma_Relative_Deadline
;