| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- E X P _ I N T R -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
| -- http://www.gnu.org/licenses for a complete copy of the license. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Atree; use Atree; |
| with Aspects; use Aspects; |
| with Checks; use Checks; |
| with Einfo; use Einfo; |
| with Einfo.Entities; use Einfo.Entities; |
| with Einfo.Utils; use Einfo.Utils; |
| with Elists; use Elists; |
| with Errout; use Errout; |
| with Expander; use Expander; |
| with Exp_Atag; use Exp_Atag; |
| with Exp_Ch6; use Exp_Ch6; |
| with Exp_Ch7; use Exp_Ch7; |
| with Exp_Ch11; use Exp_Ch11; |
| with Exp_Code; use Exp_Code; |
| with Exp_Fixd; use Exp_Fixd; |
| with Exp_Util; use Exp_Util; |
| with Freeze; use Freeze; |
| with Inline; use Inline; |
| with Nmake; use Nmake; |
| with Nlists; use Nlists; |
| with Opt; use Opt; |
| with Restrict; use Restrict; |
| with Rident; use Rident; |
| with Rtsfind; use Rtsfind; |
| with Sem; use Sem; |
| with Sem_Aux; use Sem_Aux; |
| with Sem_Eval; use Sem_Eval; |
| with Sem_Res; use Sem_Res; |
| with Sem_Type; use Sem_Type; |
| with Sem_Util; use Sem_Util; |
| with Sinfo; use Sinfo; |
| with Sinfo.Nodes; use Sinfo.Nodes; |
| with Sinfo.Utils; use Sinfo.Utils; |
| with Sinput; use Sinput; |
| with Snames; use Snames; |
| with Stand; use Stand; |
| with Tbuild; use Tbuild; |
| with Uintp; use Uintp; |
| |
| package body Exp_Intr is |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| procedure Expand_Binary_Operator_Call (N : Node_Id); |
| -- Expand a call to an intrinsic arithmetic operator when the operand |
| -- types or sizes are not identical. |
| |
| procedure Expand_Dispatching_Constructor_Call (N : Node_Id); |
| -- Expand a call to an instantiation of Generic_Dispatching_Constructor |
| -- into a dispatching call to the actual subprogram associated with the |
| -- Constructor formal subprogram, passing it the Parameters actual of |
| -- the call to the instantiation and dispatching based on call's Tag |
| -- parameter. |
| |
| procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id); |
| -- Expand a call to Exception_Information/Message/Name. The first |
| -- parameter, N, is the node for the function call, and Ent is the |
| -- entity for the corresponding routine in the Ada.Exceptions package. |
| |
| procedure Expand_Import_Call (N : Node_Id); |
| -- Expand a call to Import_Address/Longest_Integer/Value. The parameter |
| -- N is the node for the function call. |
| |
| procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind); |
| -- Expand an intrinsic shift operation, N and E are from the call to |
| -- Expand_Intrinsic_Call (call node and subprogram spec entity) and |
| -- K is the kind for the shift node |
| |
| procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id); |
| -- Expand a call to an instantiation of Unchecked_Conversion into a node |
| -- N_Unchecked_Type_Conversion. |
| |
| procedure Expand_Unc_Deallocation (N : Node_Id); |
| -- Expand a call to an instantiation of Unchecked_Deallocation into a node |
| -- N_Free_Statement and appropriate context. |
| |
| procedure Expand_To_Address (N : Node_Id); |
| procedure Expand_To_Pointer (N : Node_Id); |
| -- Expand a call to corresponding function, declared in an instance of |
| -- System.Address_To_Access_Conversions. |
| |
| procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id); |
| -- Rewrite the node as the appropriate string literal or positive |
| -- constant. Nam is the name of one of the intrinsics declared in |
| -- GNAT.Source_Info; see g-souinf.ads for documentation of these |
| -- intrinsics. |
| |
| --------------------- |
| -- Add_Source_Info -- |
| --------------------- |
| |
| procedure Add_Source_Info |
| (Buf : in out Bounded_String; |
| Loc : Source_Ptr; |
| Nam : Name_Id) |
| is |
| begin |
| case Nam is |
| when Name_Line => |
| Append (Buf, Nat (Get_Logical_Line_Number (Loc))); |
| |
| when Name_File => |
| Append (Buf, Reference_Name (Get_Source_File_Index (Loc))); |
| |
| when Name_Source_Location => |
| Build_Location_String (Buf, Loc); |
| |
| when Name_Enclosing_Entity => |
| |
| -- Skip enclosing blocks to reach enclosing unit |
| |
| declare |
| Ent : Entity_Id := Current_Scope; |
| begin |
| while Present (Ent) loop |
| exit when Ekind (Ent) not in E_Block | E_Loop; |
| Ent := Scope (Ent); |
| end loop; |
| |
| -- Ent now points to the relevant defining entity |
| |
| Append_Entity_Name (Buf, Ent); |
| end; |
| |
| when Name_Compilation_ISO_Date => |
| Append (Buf, Opt.Compilation_Time (1 .. 10)); |
| |
| when Name_Compilation_Date => |
| declare |
| subtype S13 is String (1 .. 3); |
| Months : constant array (1 .. 12) of S13 := |
| ("Jan", "Feb", "Mar", "Apr", "May", "Jun", |
| "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"); |
| |
| M1 : constant Character := Opt.Compilation_Time (6); |
| M2 : constant Character := Opt.Compilation_Time (7); |
| |
| MM : constant Natural range 1 .. 12 := |
| (Character'Pos (M1) - Character'Pos ('0')) * 10 + |
| (Character'Pos (M2) - Character'Pos ('0')); |
| |
| begin |
| -- Reformat ISO date into MMM DD YYYY (__DATE__) format |
| |
| Append (Buf, Months (MM)); |
| Append (Buf, ' '); |
| Append (Buf, Opt.Compilation_Time (9 .. 10)); |
| Append (Buf, ' '); |
| Append (Buf, Opt.Compilation_Time (1 .. 4)); |
| end; |
| |
| when Name_Compilation_Time => |
| Append (Buf, Opt.Compilation_Time (12 .. 19)); |
| |
| when others => |
| raise Program_Error; |
| end case; |
| end Add_Source_Info; |
| |
| --------------------------------- |
| -- Expand_Binary_Operator_Call -- |
| --------------------------------- |
| |
| procedure Expand_Binary_Operator_Call (N : Node_Id) is |
| T1 : constant Entity_Id := Underlying_Type (Etype (Left_Opnd (N))); |
| T2 : constant Entity_Id := Underlying_Type (Etype (Right_Opnd (N))); |
| TR : constant Entity_Id := Etype (N); |
| T3 : Entity_Id; |
| Res : Node_Id; |
| |
| Siz : constant Uint := UI_Max (RM_Size (T1), RM_Size (T2)); |
| -- Maximum of operand sizes |
| |
| begin |
| -- Nothing to do if the operands have the same modular type |
| |
| if Base_Type (T1) = Base_Type (T2) |
| and then Is_Modular_Integer_Type (T1) |
| then |
| return; |
| end if; |
| |
| -- Use the appropriate type for the size |
| |
| if Siz <= 32 then |
| T3 := RTE (RE_Unsigned_32); |
| |
| elsif Siz <= 64 then |
| T3 := RTE (RE_Unsigned_64); |
| |
| else pragma Assert (Siz <= 128); |
| T3 := RTE (RE_Unsigned_128); |
| end if; |
| |
| -- Copy operator node, and reset type and entity fields, for |
| -- subsequent reanalysis. |
| |
| Res := New_Copy (N); |
| Set_Etype (Res, T3); |
| |
| case Nkind (N) is |
| when N_Op_And => Set_Entity (Res, Standard_Op_And); |
| when N_Op_Or => Set_Entity (Res, Standard_Op_Or); |
| when N_Op_Xor => Set_Entity (Res, Standard_Op_Xor); |
| when others => raise Program_Error; |
| end case; |
| |
| -- Convert operands to large enough intermediate type |
| |
| Set_Left_Opnd (Res, |
| Unchecked_Convert_To (T3, Relocate_Node (Left_Opnd (N)))); |
| Set_Right_Opnd (Res, |
| Unchecked_Convert_To (T3, Relocate_Node (Right_Opnd (N)))); |
| |
| -- Analyze and resolve result formed by conversion to target type |
| |
| Rewrite (N, Unchecked_Convert_To (TR, Res)); |
| Analyze_And_Resolve (N, TR); |
| end Expand_Binary_Operator_Call; |
| |
| ----------------------------------------- |
| -- Expand_Dispatching_Constructor_Call -- |
| ----------------------------------------- |
| |
| -- Transform a call to an instantiation of Generic_Dispatching_Constructor |
| -- of the form: |
| |
| -- GDC_Instance (The_Tag, Parameters'Access) |
| |
| -- to a class-wide conversion of a dispatching call to the actual |
| -- associated with the formal subprogram Construct, designating The_Tag |
| -- as the controlling tag of the call: |
| |
| -- T'Class (Construct'Actual (Params)) -- Controlling tag is The_Tag |
| |
| -- which will eventually be expanded to the following: |
| |
| -- T'Class (The_Tag.all (Construct'Actual'Index).all (Params)) |
| |
| -- A class-wide membership test is also generated, preceding the call, to |
| -- ensure that the controlling tag denotes a type in T'Class. |
| |
| procedure Expand_Dispatching_Constructor_Call (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Tag_Arg : constant Node_Id := First_Actual (N); |
| Param_Arg : constant Node_Id := Next_Actual (Tag_Arg); |
| Subp_Decl : constant Node_Id := Parent (Parent (Entity (Name (N)))); |
| Inst_Pkg : constant Node_Id := Parent (Subp_Decl); |
| Act_Rename : Node_Id; |
| Act_Constr : Entity_Id; |
| Iface_Tag : Node_Id := Empty; |
| Cnstr_Call : Node_Id; |
| Result_Typ : Entity_Id; |
| |
| begin |
| pragma Assert (Is_Class_Wide_Type (Etype (Entity (Name (N))))); |
| |
| -- Report case where we know that the generated code is wrong; that |
| -- is a dispatching constructor call whose controlling type has tasks |
| -- but its root type does not have tasks. In such case the constructor |
| -- subprogram of the root type does not have extra formals but the |
| -- constructor of the derivation must have extra formals. |
| |
| if not Global_No_Tasking |
| and then not No_Run_Time_Mode |
| and then Is_Build_In_Place_Function (Entity (Name (N))) |
| and then not Has_Task (Root_Type (Etype (Entity (Name (N))))) |
| and then not Has_Aspect (Root_Type (Etype (Entity (Name (N)))), |
| Aspect_No_Task_Parts) |
| then |
| -- Case 1: Explicit tag reference (which allows static check) |
| |
| if Nkind (Tag_Arg) = N_Identifier |
| and then Present (Entity (Tag_Arg)) |
| and then Is_Tag (Entity (Tag_Arg)) |
| then |
| if Has_Task (Related_Type (Entity (Tag_Arg))) then |
| Error_Msg_N ("unsupported dispatching constructor call", N); |
| Error_Msg_NE |
| ("\work around this problem by defining task component " |
| & "type& using access-to-task-type", |
| N, Related_Type (Entity (Tag_Arg))); |
| end if; |
| |
| -- Case 2: Dynamic tag which may fail at run time |
| |
| else |
| Error_Msg_N |
| ("unsupported dispatching constructor call if the type " |
| & "of the built object has task components??", N); |
| |
| Error_Msg_Sloc := Sloc (Root_Type (Etype (Entity (Name (N))))); |
| Error_Msg_NE |
| ("\work around this by adding ''with no_task_parts'' to " |
| & "the declaration of the root type& defined#???", |
| N, Root_Type (Etype (Entity (Name (N))))); |
| end if; |
| end if; |
| |
| -- Remove side effects from tag argument early, before rewriting |
| -- the dispatching constructor call, as Remove_Side_Effects relies |
| -- on Tag_Arg's Parent link properly attached to the tree (once the |
| -- call is rewritten, the Parent is inconsistent as it points to the |
| -- rewritten node, which is not the syntactic parent of the Tag_Arg |
| -- anymore). |
| |
| Remove_Side_Effects (Tag_Arg); |
| |
| -- Check that we have a proper tag |
| |
| Insert_Action (N, |
| Make_Implicit_If_Statement (N, |
| Condition => Make_Op_Eq (Loc, |
| Left_Opnd => New_Copy_Tree (Tag_Arg), |
| Right_Opnd => New_Occurrence_Of (RTE (RE_No_Tag), Loc)), |
| |
| Then_Statements => New_List ( |
| Make_Raise_Statement (Loc, |
| New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); |
| |
| -- Check that it is not the tag of an abstract type |
| |
| Insert_Action (N, |
| Make_Implicit_If_Statement (N, |
| Condition => Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Is_Abstract), Loc), |
| Parameter_Associations => New_List (New_Copy_Tree (Tag_Arg))), |
| |
| Then_Statements => New_List ( |
| Make_Raise_Statement (Loc, |
| New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); |
| |
| -- The subprogram is the third actual in the instantiation, and is |
| -- retrieved from the corresponding renaming declaration. However, |
| -- freeze nodes may appear before, so we retrieve the declaration |
| -- with an explicit loop. |
| |
| Act_Rename := First (Visible_Declarations (Inst_Pkg)); |
| while Nkind (Act_Rename) /= N_Subprogram_Renaming_Declaration loop |
| Next (Act_Rename); |
| end loop; |
| |
| Act_Constr := Entity (Name (Act_Rename)); |
| Result_Typ := Class_Wide_Type (Etype (Act_Constr)); |
| |
| -- Check that the accessibility level of the tag is no deeper than that |
| -- of the constructor function (unless CodePeer_Mode). |
| |
| if not CodePeer_Mode then |
| Insert_Action (N, |
| Make_Implicit_If_Statement (N, |
| Condition => |
| Make_Op_Gt (Loc, |
| Left_Opnd => |
| Build_Get_Access_Level (Loc, New_Copy_Tree (Tag_Arg)), |
| Right_Opnd => |
| Make_Integer_Literal |
| (Loc, Scope_Depth_Default_0 (Act_Constr))), |
| |
| Then_Statements => New_List ( |
| Make_Raise_Statement (Loc, |
| New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); |
| end if; |
| |
| if Is_Interface (Etype (Act_Constr)) then |
| |
| -- If the result type is not known to be a parent of Tag_Arg then we |
| -- need to locate the tag of the secondary dispatch table. |
| |
| if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg), |
| Use_Full_View => True) |
| and then Tagged_Type_Expansion |
| then |
| -- Obtain the reference to the Ada.Tags service before generating |
| -- the Object_Declaration node to ensure that if this service is |
| -- not available in the runtime then we generate a clear error. |
| |
| declare |
| Fname : constant Node_Id := |
| New_Occurrence_Of (RTE (RE_Secondary_Tag), Loc); |
| |
| begin |
| pragma Assert (not Is_Interface (Etype (Tag_Arg))); |
| |
| -- The tag is the first entry in the dispatch table of the |
| -- return type of the constructor. |
| |
| Iface_Tag := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Make_Temporary (Loc, 'V'), |
| Object_Definition => |
| New_Occurrence_Of (RTE (RE_Tag), Loc), |
| Expression => |
| Make_Function_Call (Loc, |
| Name => Fname, |
| Parameter_Associations => New_List ( |
| Relocate_Node (Tag_Arg), |
| New_Occurrence_Of |
| (Node (First_Elmt |
| (Access_Disp_Table (Etype (Act_Constr)))), |
| Loc)))); |
| Insert_Action (N, Iface_Tag); |
| end; |
| end if; |
| end if; |
| |
| -- Create the call to the actual Constructor function |
| |
| Cnstr_Call := |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (Act_Constr, Loc), |
| Parameter_Associations => New_List (Relocate_Node (Param_Arg))); |
| |
| -- Establish its controlling tag from the tag passed to the instance |
| -- The tag may be given by a function call, in which case a temporary |
| -- should be generated now, to prevent out-of-order insertions during |
| -- the expansion of that call when stack-checking is enabled. |
| |
| if Present (Iface_Tag) then |
| Set_Controlling_Argument (Cnstr_Call, |
| New_Occurrence_Of (Defining_Identifier (Iface_Tag), Loc)); |
| else |
| Set_Controlling_Argument (Cnstr_Call, |
| Relocate_Node (Tag_Arg)); |
| end if; |
| |
| -- Rewrite and analyze the call to the instance as a class-wide |
| -- conversion of the call to the actual constructor. When the result |
| -- type is a class-wide interface type this conversion is required to |
| -- force the displacement of the pointer to the object to reference the |
| -- corresponding dispatch table. |
| |
| Rewrite (N, Convert_To (Result_Typ, Cnstr_Call)); |
| |
| -- Do not generate a run-time check on the built object if tag |
| -- checks are suppressed for the result type or tagged type expansion |
| -- is disabled or if CodePeer_Mode. |
| |
| if Tag_Checks_Suppressed (Etype (Result_Typ)) |
| or else not Tagged_Type_Expansion |
| or else CodePeer_Mode |
| then |
| null; |
| |
| -- Generate a class-wide membership test to ensure that the call's tag |
| -- argument denotes a type within the class. We must keep separate the |
| -- case in which the Result_Type of the constructor function is a tagged |
| -- type from the case in which it is an abstract interface because the |
| -- run-time subprogram required to check these cases differ (and have |
| -- one difference in their parameters profile). |
| |
| -- Call CW_Membership if the Result_Type is a tagged type to look for |
| -- the tag in the table of ancestor tags. |
| |
| elsif not Is_Interface (Result_Typ) then |
| Insert_Action (N, |
| Make_Implicit_If_Statement (N, |
| Condition => |
| Make_Op_Not (Loc, |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_CW_Membership), Loc), |
| Parameter_Associations => New_List ( |
| New_Copy_Tree (Tag_Arg), |
| New_Occurrence_Of ( |
| Node (First_Elmt (Access_Disp_Table ( |
| Root_Type (Result_Typ)))), Loc)))), |
| Then_Statements => |
| New_List ( |
| Make_Raise_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); |
| |
| -- Call IW_Membership test if the Result_Type is an abstract interface |
| -- to look for the tag in the table of interface tags. |
| |
| else |
| Insert_Action (N, |
| Make_Implicit_If_Statement (N, |
| Condition => |
| Make_Op_Not (Loc, |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc), |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Copy_Tree (Tag_Arg), |
| Attribute_Name => Name_Address), |
| |
| New_Occurrence_Of ( |
| Node (First_Elmt (Access_Disp_Table ( |
| Root_Type (Result_Typ)))), Loc)))), |
| Then_Statements => |
| New_List ( |
| Make_Raise_Statement (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); |
| end if; |
| |
| Analyze_And_Resolve (N, Etype (Act_Constr)); |
| end Expand_Dispatching_Constructor_Call; |
| |
| --------------------------- |
| -- Expand_Exception_Call -- |
| --------------------------- |
| |
| -- If the function call is not within an exception handler, then the call |
| -- is replaced by a null string. Otherwise the appropriate routine in |
| -- Ada.Exceptions is called passing the choice parameter specification |
| -- from the enclosing handler. If the enclosing handler lacks a choice |
| -- parameter, then one is supplied. |
| |
| procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| P : Node_Id; |
| E : Entity_Id; |
| |
| begin |
| -- Climb up parents to see if we are in exception handler |
| |
| P := Parent (N); |
| loop |
| -- Case of not in exception handler, replace by null string |
| |
| if No (P) then |
| Rewrite (N, |
| Make_String_Literal (Loc, |
| Strval => "")); |
| exit; |
| |
| -- Case of in exception handler |
| |
| elsif Nkind (P) = N_Exception_Handler then |
| |
| -- Handler cannot be used for a local raise, and furthermore, this |
| -- is a violation of the No_Exception_Propagation restriction. |
| |
| Set_Local_Raise_Not_OK (P); |
| Check_Restriction (No_Exception_Propagation, N); |
| |
| -- If no choice parameter present, then put one there. Note that |
| -- we do not need to put it on the entity chain, since no one will |
| -- be referencing it by normal visibility methods. |
| |
| if No (Choice_Parameter (P)) then |
| E := Make_Temporary (Loc, 'E'); |
| Set_Choice_Parameter (P, E); |
| Mutate_Ekind (E, E_Variable); |
| Set_Etype (E, RTE (RE_Exception_Occurrence)); |
| Set_Scope (E, Current_Scope); |
| end if; |
| |
| Rewrite (N, |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (Ent), Loc), |
| Parameter_Associations => New_List ( |
| New_Occurrence_Of (Choice_Parameter (P), Loc)))); |
| exit; |
| |
| -- Keep climbing |
| |
| else |
| P := Parent (P); |
| end if; |
| end loop; |
| |
| Analyze_And_Resolve (N, Standard_String); |
| end Expand_Exception_Call; |
| |
| ------------------------ |
| -- Expand_Import_Call -- |
| ------------------------ |
| |
| -- The function call must have a static string as its argument. We create |
| -- a dummy variable which uses this string as the external name in an |
| -- Import pragma. The result is then obtained as the address of this |
| -- dummy variable, converted to the appropriate target type. |
| |
| procedure Expand_Import_Call (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Ent : constant Entity_Id := Entity (Name (N)); |
| Str : constant Node_Id := First_Actual (N); |
| Dum : constant Entity_Id := Make_Temporary (Loc, 'D'); |
| |
| begin |
| Insert_Actions (N, New_List ( |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Dum, |
| Object_Definition => |
| New_Occurrence_Of (Standard_Character, Loc)), |
| |
| Make_Pragma (Loc, |
| Chars => Name_Import, |
| Pragma_Argument_Associations => New_List ( |
| Make_Pragma_Argument_Association (Loc, |
| Expression => Make_Identifier (Loc, Name_Ada)), |
| |
| Make_Pragma_Argument_Association (Loc, |
| Expression => Make_Identifier (Loc, Chars (Dum))), |
| |
| Make_Pragma_Argument_Association (Loc, |
| Chars => Name_Link_Name, |
| Expression => Relocate_Node (Str)))))); |
| |
| Rewrite (N, |
| Unchecked_Convert_To (Etype (Ent), |
| Make_Attribute_Reference (Loc, |
| Prefix => Make_Identifier (Loc, Chars (Dum)), |
| Attribute_Name => Name_Address))); |
| |
| Analyze_And_Resolve (N, Etype (Ent)); |
| end Expand_Import_Call; |
| |
| --------------------------- |
| -- Expand_Intrinsic_Call -- |
| --------------------------- |
| |
| procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id) is |
| Nam : Name_Id; |
| |
| begin |
| -- If an external name is specified for the intrinsic, it is handled |
| -- by the back-end: leave the call node unchanged for now. |
| |
| if Present (Interface_Name (E)) then |
| return; |
| end if; |
| |
| -- If the intrinsic subprogram is generic, gets its original name |
| |
| if Present (Parent (E)) |
| and then Present (Generic_Parent (Parent (E))) |
| then |
| Nam := Chars (Generic_Parent (Parent (E))); |
| else |
| Nam := Chars (E); |
| end if; |
| |
| if Nam = Name_Asm then |
| Expand_Asm_Call (N); |
| |
| elsif Nam = Name_Divide then |
| Expand_Decimal_Divide_Call (N); |
| |
| elsif Nam = Name_Exception_Information then |
| Expand_Exception_Call (N, RE_Exception_Information); |
| |
| elsif Nam = Name_Exception_Message then |
| Expand_Exception_Call (N, RE_Exception_Message); |
| |
| elsif Nam = Name_Exception_Name then |
| Expand_Exception_Call (N, RE_Exception_Name_Simple); |
| |
| elsif Nam = Name_Generic_Dispatching_Constructor then |
| Expand_Dispatching_Constructor_Call (N); |
| |
| elsif Nam in Name_Import_Address |
| | Name_Import_Largest_Value |
| | Name_Import_Value |
| then |
| Expand_Import_Call (N); |
| |
| elsif Nam = Name_Rotate_Left then |
| Expand_Shift (N, E, N_Op_Rotate_Left); |
| |
| elsif Nam = Name_Rotate_Right then |
| Expand_Shift (N, E, N_Op_Rotate_Right); |
| |
| elsif Nam = Name_Shift_Left then |
| Expand_Shift (N, E, N_Op_Shift_Left); |
| |
| elsif Nam = Name_Shift_Right then |
| Expand_Shift (N, E, N_Op_Shift_Right); |
| |
| elsif Nam = Name_Shift_Right_Arithmetic then |
| Expand_Shift (N, E, N_Op_Shift_Right_Arithmetic); |
| |
| elsif Nam = Name_Unchecked_Conversion then |
| Expand_Unc_Conversion (N, E); |
| |
| elsif Nam = Name_Unchecked_Deallocation then |
| Expand_Unc_Deallocation (N); |
| |
| elsif Nam = Name_To_Address then |
| Expand_To_Address (N); |
| |
| elsif Nam = Name_To_Pointer then |
| Expand_To_Pointer (N); |
| |
| elsif Nam in Name_File |
| | Name_Line |
| | Name_Source_Location |
| | Name_Enclosing_Entity |
| | Name_Compilation_ISO_Date |
| | Name_Compilation_Date |
| | Name_Compilation_Time |
| then |
| Expand_Source_Info (N, Nam); |
| |
| -- If we have a renaming, expand the call to the original operation, |
| -- which must itself be intrinsic, since renaming requires matching |
| -- conventions and this has already been checked. |
| |
| elsif Present (Alias (E)) then |
| Expand_Intrinsic_Call (N, Alias (E)); |
| |
| elsif Nkind (N) in N_Binary_Op then |
| Expand_Binary_Operator_Call (N); |
| |
| -- The only other case is where an external name was specified, since |
| -- this is the only way that an otherwise unrecognized name could |
| -- escape the checking in Sem_Prag. Nothing needs to be done in such |
| -- a case, since we pass such a call to the back end unchanged. |
| |
| else |
| null; |
| end if; |
| end Expand_Intrinsic_Call; |
| |
| ------------------ |
| -- Expand_Shift -- |
| ------------------ |
| |
| -- This procedure is used to convert a call to a shift function to the |
| -- corresponding operator node. This conversion is not done by the usual |
| -- circuit for converting calls to operator functions (e.g. "+"(1,2)) to |
| -- operator nodes, because shifts are not predefined operators. |
| |
| -- As a result, whenever a shift is used in the source program, it will |
| -- remain as a call until converted by this routine to the operator node |
| -- form which the back end is expecting to see. |
| |
| -- Note: it is possible for the expander to generate shift operator nodes |
| -- directly, which will be analyzed in the normal manner by calling Analyze |
| -- and Resolve. Such shift operator nodes will not be seen by Expand_Shift. |
| |
| procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind) is |
| Entyp : constant Entity_Id := Etype (E); |
| Left : constant Node_Id := First_Actual (N); |
| Loc : constant Source_Ptr := Sloc (N); |
| Right : constant Node_Id := Next_Actual (Left); |
| Ltyp : constant Node_Id := Etype (Left); |
| Rtyp : constant Node_Id := Etype (Right); |
| Typ : constant Entity_Id := Etype (N); |
| Snode : Node_Id; |
| |
| begin |
| Snode := New_Node (K, Loc); |
| Set_Right_Opnd (Snode, Relocate_Node (Right)); |
| Set_Chars (Snode, Chars (E)); |
| Set_Etype (Snode, Base_Type (Entyp)); |
| Set_Entity (Snode, E); |
| |
| if Compile_Time_Known_Value (Type_High_Bound (Rtyp)) |
| and then Expr_Value (Type_High_Bound (Rtyp)) < Esize (Ltyp) |
| then |
| Set_Shift_Count_OK (Snode, True); |
| end if; |
| |
| if Typ = Entyp then |
| |
| -- Note that we don't call Analyze and Resolve on this node, because |
| -- it already got analyzed and resolved when it was a function call. |
| |
| Set_Left_Opnd (Snode, Relocate_Node (Left)); |
| Rewrite (N, Snode); |
| Set_Analyzed (N); |
| |
| -- However, we do call the expander, so that the expansion for |
| -- rotates and shift_right_arithmetic happens if Modify_Tree_For_C |
| -- is set. |
| |
| if Expander_Active then |
| Expand (N); |
| end if; |
| |
| else |
| -- If the context type is not the type of the operator, it is an |
| -- inherited operator for a derived type. Wrap the node in a |
| -- conversion so that it is type-consistent for possible further |
| -- expansion (e.g. within a lock-free protected type). |
| |
| Set_Left_Opnd (Snode, |
| Unchecked_Convert_To (Base_Type (Entyp), Relocate_Node (Left))); |
| Rewrite (N, Unchecked_Convert_To (Typ, Snode)); |
| |
| -- Analyze and resolve result formed by conversion to target type |
| |
| Analyze_And_Resolve (N, Typ); |
| end if; |
| end Expand_Shift; |
| |
| ------------------------ |
| -- Expand_Source_Info -- |
| ------------------------ |
| |
| procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| begin |
| -- Integer cases |
| |
| if Nam = Name_Line then |
| Rewrite (N, |
| Make_Integer_Literal (Loc, |
| Intval => UI_From_Int (Int (Get_Logical_Line_Number (Loc))))); |
| Analyze_And_Resolve (N, Standard_Positive); |
| |
| -- String cases |
| |
| else |
| declare |
| Buf : Bounded_String; |
| begin |
| Add_Source_Info (Buf, Loc, Nam); |
| Rewrite (N, Make_String_Literal (Loc, Strval => +Buf)); |
| Analyze_And_Resolve (N, Standard_String); |
| end; |
| end if; |
| |
| Set_Is_Static_Expression (N); |
| end Expand_Source_Info; |
| |
| --------------------------- |
| -- Expand_Unc_Conversion -- |
| --------------------------- |
| |
| procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id) is |
| Func : constant Entity_Id := Entity (Name (N)); |
| Conv : Node_Id; |
| Ftyp : Entity_Id; |
| Ttyp : Entity_Id; |
| |
| begin |
| -- Rewrite as unchecked conversion node. Note that we must convert |
| -- the operand to the formal type of the input parameter of the |
| -- function, so that the resulting N_Unchecked_Type_Conversion |
| -- call indicates the correct types for Gigi. |
| |
| -- Right now, we only do this if a scalar type is involved. It is |
| -- not clear if it is needed in other cases. If we do attempt to |
| -- do the conversion unconditionally, it crashes 3411-018. To be |
| -- investigated further ??? |
| |
| Conv := Relocate_Node (First_Actual (N)); |
| Ftyp := Etype (First_Formal (Func)); |
| |
| if Is_Scalar_Type (Ftyp) then |
| Conv := Convert_To (Ftyp, Conv); |
| Set_Parent (Conv, N); |
| Analyze_And_Resolve (Conv); |
| end if; |
| |
| -- The instantiation of Unchecked_Conversion creates a wrapper package, |
| -- and the target type is declared as a subtype of the actual. Recover |
| -- the actual, which is the subtype indic. in the subtype declaration |
| -- for the target type. This is semantically correct, and avoids |
| -- anomalies with access subtypes. For entities, leave type as is. |
| |
| -- We do the analysis here, because we do not want the compiler |
| -- to try to optimize or otherwise reorganize the unchecked |
| -- conversion node. |
| |
| Ttyp := Etype (E); |
| |
| if Is_Entity_Name (Conv) then |
| null; |
| |
| elsif Nkind (Parent (Ttyp)) = N_Subtype_Declaration then |
| Ttyp := Entity (Subtype_Indication (Parent (Etype (E)))); |
| |
| elsif Is_Itype (Ttyp) then |
| Ttyp := |
| Entity (Subtype_Indication (Associated_Node_For_Itype (Ttyp))); |
| else |
| raise Program_Error; |
| end if; |
| |
| Rewrite (N, Unchecked_Convert_To (Ttyp, Conv)); |
| Analyze_And_Resolve (N, Ttyp); |
| end Expand_Unc_Conversion; |
| |
| ----------------------------- |
| -- Expand_Unc_Deallocation -- |
| ----------------------------- |
| |
| procedure Expand_Unc_Deallocation (N : Node_Id) is |
| Arg : constant Node_Id := First_Actual (N); |
| Loc : constant Source_Ptr := Sloc (N); |
| Typ : constant Entity_Id := Etype (Arg); |
| Desig_Typ : constant Entity_Id := |
| Available_View (Designated_Type (Typ)); |
| Needs_Fin : constant Boolean := Needs_Finalization (Desig_Typ); |
| Root_Typ : constant Entity_Id := Underlying_Type (Root_Type (Typ)); |
| Pool : constant Entity_Id := Associated_Storage_Pool (Root_Typ); |
| Stmts : constant List_Id := New_List; |
| |
| Arg_Known_Non_Null : constant Boolean := Known_Non_Null (N); |
| -- This captures whether we know the argument to be non-null so that |
| -- we can avoid the test. The reason that we need to capture this is |
| -- that we analyze some generated statements before properly attaching |
| -- them to the tree, and that can disturb current value settings. |
| |
| Exceptions_OK : constant Boolean := |
| not Restriction_Active (No_Exception_Propagation); |
| |
| Abrt_Blk : Node_Id := Empty; |
| Abrt_Blk_Id : Entity_Id; |
| Abrt_HSS : Node_Id; |
| AUD : Entity_Id; |
| Fin_Blk : Node_Id; |
| Fin_Call : Node_Id; |
| Fin_Data : Finalization_Exception_Data; |
| Free_Arg : Node_Id; |
| Free_Nod : Node_Id; |
| Gen_Code : Node_Id; |
| Obj_Ref : Node_Id; |
| |
| begin |
| -- Nothing to do if we know the argument is null |
| |
| if Known_Null (N) then |
| return; |
| end if; |
| |
| -- Processing for pointer to controlled types. Generate: |
| |
| -- Abrt : constant Boolean := ...; |
| -- Ex : Exception_Occurrence; |
| -- Raised : Boolean := False; |
| |
| -- begin |
| -- Abort_Defer; |
| |
| -- begin |
| -- [Deep_]Finalize (Obj_Ref); |
| |
| -- exception |
| -- when others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence (Ex, Get_Current_Excep.all.all); |
| -- end; |
| -- at end |
| -- Abort_Undefer_Direct; |
| -- end; |
| |
| -- Depending on whether exception propagation is enabled and/or aborts |
| -- are allowed, the generated code may lack block statements. |
| |
| if Needs_Fin then |
| |
| -- Ada 2005 (AI-251): In case of abstract interface type we displace |
| -- the pointer to reference the base of the object to deallocate its |
| -- memory, unless we're targetting a VM, in which case no special |
| -- processing is required. |
| |
| if Is_Interface (Directly_Designated_Type (Typ)) |
| and then Tagged_Type_Expansion |
| then |
| Obj_Ref := |
| Make_Explicit_Dereference (Loc, |
| Prefix => |
| Unchecked_Convert_To (Typ, |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Base_Address), Loc), |
| Parameter_Associations => New_List ( |
| Unchecked_Convert_To (RTE (RE_Address), |
| Duplicate_Subexpr_No_Checks (Arg)))))); |
| |
| else |
| Obj_Ref := |
| Make_Explicit_Dereference (Loc, |
| Prefix => Duplicate_Subexpr_No_Checks (Arg)); |
| end if; |
| |
| -- If the designated type is tagged, the finalization call must |
| -- dispatch because the designated type may not be the actual type |
| -- of the object. If the type is synchronized, the deallocation |
| -- applies to the corresponding record type. |
| |
| if Is_Tagged_Type (Desig_Typ) then |
| if Is_Concurrent_Type (Desig_Typ) then |
| Obj_Ref := |
| Unchecked_Convert_To |
| (Class_Wide_Type (Corresponding_Record_Type (Desig_Typ)), |
| Obj_Ref); |
| |
| elsif not Is_Class_Wide_Type (Desig_Typ) then |
| Obj_Ref := |
| Unchecked_Convert_To (Class_Wide_Type (Desig_Typ), Obj_Ref); |
| end if; |
| |
| -- Otherwise the designated type is untagged. Set the type of the |
| -- dereference explicitly to force a conversion when needed given |
| -- that [Deep_]Finalize may be inherited from a parent type. |
| |
| else |
| Set_Etype (Obj_Ref, Desig_Typ); |
| end if; |
| |
| -- Generate: |
| -- [Deep_]Finalize (Obj_Ref); |
| |
| Fin_Call := Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ); |
| |
| -- Generate: |
| -- Abrt : constant Boolean := ...; |
| -- Ex : Exception_Occurrence; |
| -- Raised : Boolean := False; |
| |
| -- begin |
| -- <Fin_Call> |
| |
| -- exception |
| -- when others => |
| -- if not Raised then |
| -- Raised := True; |
| -- Save_Occurrence (Ex, Get_Current_Excep.all.all); |
| -- end; |
| |
| if Exceptions_OK then |
| Build_Object_Declarations (Fin_Data, Stmts, Loc); |
| |
| Fin_Blk := |
| Make_Block_Statement (Loc, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Fin_Call), |
| Exception_Handlers => New_List ( |
| Build_Exception_Handler (Fin_Data)))); |
| |
| -- Otherwise exception propagation is not allowed |
| |
| else |
| Fin_Blk := Fin_Call; |
| end if; |
| |
| -- The finalization action must be protected by an abort defer and |
| -- undefer pair when aborts are allowed. Generate: |
| |
| -- begin |
| -- Abort_Defer; |
| -- <Fin_Blk> |
| -- at end |
| -- Abort_Undefer_Direct; |
| -- end; |
| |
| if Abort_Allowed then |
| AUD := RTE (RE_Abort_Undefer_Direct); |
| |
| Abrt_HSS := |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List ( |
| Build_Runtime_Call (Loc, RE_Abort_Defer), |
| Fin_Blk), |
| At_End_Proc => New_Occurrence_Of (AUD, Loc)); |
| |
| Abrt_Blk := |
| Make_Block_Statement (Loc, |
| Handled_Statement_Sequence => Abrt_HSS); |
| |
| Add_Block_Identifier (Abrt_Blk, Abrt_Blk_Id); |
| Expand_At_End_Handler (Abrt_HSS, Abrt_Blk_Id); |
| |
| -- Present the Abort_Undefer_Direct function to the backend so |
| -- that it can inline the call to the function. |
| |
| Add_Inlined_Body (AUD, N); |
| |
| -- Otherwise aborts are not allowed |
| |
| else |
| Abrt_Blk := Fin_Blk; |
| end if; |
| |
| Append_To (Stmts, Abrt_Blk); |
| end if; |
| |
| -- For a task type, call Free_Task before freeing the ATCB. We used to |
| -- detect the case of Abort followed by a Free here, because the Free |
| -- wouldn't actually free if it happens before the aborted task actually |
| -- terminates. The warning was removed, because Free now works properly |
| -- (the task will be freed once it terminates). |
| |
| if Is_Task_Type (Desig_Typ) then |
| Append_To (Stmts, |
| Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg))); |
| |
| -- For composite types that contain tasks, recurse over the structure |
| -- to build the selectors for the task subcomponents. |
| |
| elsif Has_Task (Desig_Typ) then |
| if Is_Array_Type (Desig_Typ) then |
| Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_Typ)); |
| |
| elsif Is_Record_Type (Desig_Typ) then |
| Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_Typ)); |
| end if; |
| end if; |
| |
| -- Same for simple protected types. Eventually call Finalize_Protection |
| -- before freeing the PO for each protected component. |
| |
| if Is_Simple_Protected_Type (Desig_Typ) then |
| Append_To (Stmts, |
| Cleanup_Protected_Object (N, Duplicate_Subexpr_No_Checks (Arg))); |
| |
| elsif Has_Simple_Protected_Object (Desig_Typ) then |
| if Is_Array_Type (Desig_Typ) then |
| Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_Typ)); |
| |
| elsif Is_Record_Type (Desig_Typ) then |
| Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_Typ)); |
| end if; |
| end if; |
| |
| -- Normal processing for non-controlled types. The argument to free is |
| -- a renaming rather than a constant to ensure that the original context |
| -- is always set to null after the deallocation takes place. |
| |
| Free_Arg := Duplicate_Subexpr_No_Checks (Arg, Renaming_Req => True); |
| Free_Nod := Make_Free_Statement (Loc, Empty); |
| Append_To (Stmts, Free_Nod); |
| Set_Storage_Pool (Free_Nod, Pool); |
| |
| -- Attach to tree before analysis of generated subtypes below |
| |
| Set_Parent (Stmts, Parent (N)); |
| |
| -- Deal with storage pool |
| |
| if Present (Pool) then |
| |
| -- Freeing the secondary stack is meaningless |
| |
| if Is_RTE (Pool, RE_SS_Pool) then |
| null; |
| |
| -- If the pool object is of a simple storage pool type, then attempt |
| -- to locate the type's Deallocate procedure, if any, and set the |
| -- free operation's procedure to call. If the type doesn't have a |
| -- Deallocate (which is allowed), then the actual will simply be set |
| -- to null. |
| |
| elsif Present |
| (Get_Rep_Pragma (Etype (Pool), Name_Simple_Storage_Pool_Type)) |
| then |
| declare |
| Pool_Typ : constant Entity_Id := Base_Type (Etype (Pool)); |
| Dealloc : Entity_Id; |
| |
| begin |
| Dealloc := Get_Name_Entity_Id (Name_Deallocate); |
| while Present (Dealloc) loop |
| if Scope (Dealloc) = Scope (Pool_Typ) |
| and then Present (First_Formal (Dealloc)) |
| and then Etype (First_Formal (Dealloc)) = Pool_Typ |
| then |
| Set_Procedure_To_Call (Free_Nod, Dealloc); |
| exit; |
| else |
| Dealloc := Homonym (Dealloc); |
| end if; |
| end loop; |
| end; |
| |
| -- Case of a class-wide pool type: make a dispatching call to |
| -- Deallocate through the class-wide Deallocate_Any. |
| |
| elsif Is_Class_Wide_Type (Etype (Pool)) then |
| Set_Procedure_To_Call (Free_Nod, RTE (RE_Deallocate_Any)); |
| |
| -- Case of a specific pool type: make a statically bound call |
| |
| else |
| Set_Procedure_To_Call |
| (Free_Nod, Find_Storage_Op (Etype (Pool), Name_Deallocate)); |
| end if; |
| end if; |
| |
| if Present (Procedure_To_Call (Free_Nod)) then |
| |
| -- For all cases of a Deallocate call, the back-end needs to be able |
| -- to compute the size of the object being freed. This may require |
| -- some adjustments for objects of dynamic size. |
| -- |
| -- If the type is class wide, we generate an implicit type with the |
| -- right dynamic size, so that the deallocate call gets the right |
| -- size parameter computed by GIGI. Same for an access to |
| -- unconstrained packed array. |
| |
| if Is_Class_Wide_Type (Desig_Typ) |
| or else |
| (Is_Packed_Array (Desig_Typ) |
| and then not Is_Constrained (Desig_Typ)) |
| then |
| declare |
| Deref : constant Node_Id := |
| Make_Explicit_Dereference (Loc, |
| Duplicate_Subexpr_No_Checks (Arg)); |
| D_Subtyp : Node_Id; |
| D_Type : Entity_Id; |
| |
| begin |
| -- Perform minor decoration as it is needed by the side effect |
| -- removal mechanism. |
| |
| Set_Etype (Deref, Desig_Typ); |
| Set_Parent (Deref, Free_Nod); |
| D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_Typ); |
| |
| if Nkind (D_Subtyp) in N_Has_Entity then |
| D_Type := Entity (D_Subtyp); |
| |
| else |
| D_Type := Make_Temporary (Loc, 'A'); |
| Insert_Action (Deref, |
| Make_Subtype_Declaration (Loc, |
| Defining_Identifier => D_Type, |
| Subtype_Indication => D_Subtyp)); |
| end if; |
| |
| -- Force freezing at the point of the dereference. For the |
| -- class wide case, this avoids having the subtype frozen |
| -- before the equivalent type. |
| |
| Freeze_Itype (D_Type, Deref); |
| |
| Set_Actual_Designated_Subtype (Free_Nod, D_Type); |
| end; |
| end if; |
| end if; |
| |
| -- Ada 2005 (AI-251): In case of abstract interface type we must |
| -- displace the pointer to reference the base of the object to |
| -- deallocate its memory, unless we're targetting a VM, in which case |
| -- no special processing is required. |
| |
| -- Generate: |
| -- free (Base_Address (Obj_Ptr)) |
| |
| if Is_Interface (Directly_Designated_Type (Typ)) |
| and then Tagged_Type_Expansion |
| then |
| Set_Expression (Free_Nod, |
| Unchecked_Convert_To (Typ, |
| Make_Function_Call (Loc, |
| Name => |
| New_Occurrence_Of (RTE (RE_Base_Address), Loc), |
| Parameter_Associations => New_List ( |
| Unchecked_Convert_To (RTE (RE_Address), Free_Arg))))); |
| |
| -- Generate: |
| -- free (Obj_Ptr) |
| |
| else |
| Set_Expression (Free_Nod, Free_Arg); |
| end if; |
| |
| -- Only remaining step is to set result to null, or generate a raise of |
| -- Constraint_Error if the target object is "not null". |
| |
| if Can_Never_Be_Null (Etype (Arg)) then |
| Append_To (Stmts, |
| Make_Raise_Constraint_Error (Loc, |
| Reason => CE_Access_Check_Failed)); |
| |
| else |
| declare |
| Lhs : constant Node_Id := Duplicate_Subexpr_No_Checks (Arg); |
| begin |
| Set_Assignment_OK (Lhs); |
| Append_To (Stmts, |
| Make_Assignment_Statement (Loc, |
| Name => Lhs, |
| Expression => Make_Null (Loc))); |
| end; |
| end if; |
| |
| -- Generate a test of whether any earlier finalization raised an |
| -- exception, and in that case raise Program_Error with the previous |
| -- exception occurrence. |
| |
| -- Generate: |
| -- if Raised and then not Abrt then |
| -- raise Program_Error; -- for restricted RTS |
| -- <or> |
| -- Raise_From_Controlled_Operation (E); -- all other cases |
| -- end if; |
| |
| if Needs_Fin and then Exceptions_OK then |
| Append_To (Stmts, Build_Raise_Statement (Fin_Data)); |
| end if; |
| |
| -- If we know the argument is non-null, then make a block statement |
| -- that contains the required statements, no need for a test. |
| |
| if Arg_Known_Non_Null then |
| Gen_Code := |
| Make_Block_Statement (Loc, |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => Stmts)); |
| |
| -- If the argument may be null, wrap the statements inside an IF that |
| -- does an explicit test to exclude the null case. |
| |
| else |
| Gen_Code := |
| Make_Implicit_If_Statement (N, |
| Condition => |
| Make_Op_Ne (Loc, |
| Left_Opnd => Duplicate_Subexpr (Arg), |
| Right_Opnd => Make_Null (Loc)), |
| Then_Statements => Stmts); |
| end if; |
| |
| -- Rewrite the call |
| |
| Rewrite (N, Gen_Code); |
| Analyze (N); |
| end Expand_Unc_Deallocation; |
| |
| ----------------------- |
| -- Expand_To_Address -- |
| ----------------------- |
| |
| procedure Expand_To_Address (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Arg : constant Node_Id := First_Actual (N); |
| Obj : Node_Id; |
| |
| begin |
| Remove_Side_Effects (Arg); |
| |
| Obj := Make_Explicit_Dereference (Loc, Relocate_Node (Arg)); |
| |
| Rewrite (N, |
| Make_If_Expression (Loc, |
| Expressions => New_List ( |
| Make_Op_Eq (Loc, |
| Left_Opnd => New_Copy_Tree (Arg), |
| Right_Opnd => Make_Null (Loc)), |
| New_Occurrence_Of (RTE (RE_Null_Address), Loc), |
| Make_Attribute_Reference (Loc, |
| Prefix => Obj, |
| Attribute_Name => Name_Address)))); |
| |
| Analyze_And_Resolve (N, RTE (RE_Address)); |
| end Expand_To_Address; |
| |
| ----------------------- |
| -- Expand_To_Pointer -- |
| ----------------------- |
| |
| procedure Expand_To_Pointer (N : Node_Id) is |
| Arg : constant Node_Id := First_Actual (N); |
| |
| begin |
| Rewrite (N, Unchecked_Convert_To (Etype (N), Arg)); |
| Analyze (N); |
| end Expand_To_Pointer; |
| |
| end Exp_Intr; |
