| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- E X P _ C H 1 3 -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2005, 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 2, 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 COPYING. If not, write -- |
| -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- |
| -- Boston, MA 02110-1301, USA. -- |
| -- -- |
| -- 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 Checks; use Checks; |
| with Einfo; use Einfo; |
| with Exp_Ch3; use Exp_Ch3; |
| with Exp_Ch6; use Exp_Ch6; |
| with Exp_Imgv; use Exp_Imgv; |
| with Exp_Tss; use Exp_Tss; |
| with Exp_Util; use Exp_Util; |
| with Nlists; use Nlists; |
| with Nmake; use Nmake; |
| with Rtsfind; use Rtsfind; |
| with Sem; use Sem; |
| with Sem_Ch7; use Sem_Ch7; |
| with Sem_Ch8; use Sem_Ch8; |
| with Sem_Eval; use Sem_Eval; |
| with Sem_Util; use Sem_Util; |
| with Sinfo; use Sinfo; |
| with Snames; use Snames; |
| with Stand; use Stand; |
| with Stringt; use Stringt; |
| with Tbuild; use Tbuild; |
| with Uintp; use Uintp; |
| |
| package body Exp_Ch13 is |
| |
| procedure Expand_External_Tag_Definition (N : Node_Id); |
| -- The code to assign and register an external tag must be elaborated |
| -- after the dispatch table has been created, so the expansion of the |
| -- attribute definition node is delayed until after the type is frozen. |
| |
| ------------------------------------------ |
| -- Expand_N_Attribute_Definition_Clause -- |
| ------------------------------------------ |
| |
| -- Expansion action depends on attribute involved |
| |
| procedure Expand_N_Attribute_Definition_Clause (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Exp : constant Node_Id := Expression (N); |
| Ent : Entity_Id; |
| V : Node_Id; |
| |
| begin |
| Ent := Entity (Name (N)); |
| |
| if Is_Type (Ent) then |
| Ent := Underlying_Type (Ent); |
| end if; |
| |
| case Get_Attribute_Id (Chars (N)) is |
| |
| ------------- |
| -- Address -- |
| ------------- |
| |
| when Attribute_Address => |
| |
| -- If there is an initialization which did not come from |
| -- the source program, then it is an artifact of our |
| -- expansion, and we suppress it. The case we are most |
| -- concerned about here is the initialization of a packed |
| -- array to all false, which seems inappropriate for a |
| -- variable to which an address clause is applied. The |
| -- expression may itself have been rewritten if the type is a |
| -- packed array, so we need to examine whether the original |
| -- node is in the source. |
| |
| declare |
| Decl : constant Node_Id := Declaration_Node (Ent); |
| begin |
| if Nkind (Decl) = N_Object_Declaration |
| and then Present (Expression (Decl)) |
| and then |
| not Comes_From_Source (Original_Node (Expression (Decl))) |
| then |
| Set_Expression (Decl, Empty); |
| end if; |
| end; |
| |
| --------------- |
| -- Alignment -- |
| --------------- |
| |
| when Attribute_Alignment => |
| |
| -- As required by Gigi, we guarantee that the operand is an |
| -- integer literal (this simplifies things in Gigi). |
| |
| if Nkind (Exp) /= N_Integer_Literal then |
| Rewrite |
| (Exp, Make_Integer_Literal (Loc, Expr_Value (Exp))); |
| end if; |
| |
| ------------------ |
| -- Storage_Size -- |
| ------------------ |
| |
| when Attribute_Storage_Size => |
| |
| -- If the type is a task type, then assign the value of the |
| -- storage size to the Size variable associated with the task. |
| -- task_typeZ := expression |
| |
| if Ekind (Ent) = E_Task_Type then |
| Insert_Action (N, |
| Make_Assignment_Statement (Loc, |
| Name => New_Reference_To (Storage_Size_Variable (Ent), Loc), |
| Expression => |
| Convert_To (RTE (RE_Size_Type), Expression (N)))); |
| |
| -- For Storage_Size for an access type, create a variable to hold |
| -- the value of the specified size with name typeV and expand an |
| -- assignment statement to initialze this value. |
| |
| elsif Is_Access_Type (Ent) then |
| |
| V := Make_Defining_Identifier (Loc, |
| New_External_Name (Chars (Ent), 'V')); |
| |
| Insert_Action (N, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => V, |
| Object_Definition => |
| New_Reference_To (RTE (RE_Storage_Offset), Loc), |
| Expression => |
| Convert_To (RTE (RE_Storage_Offset), Expression (N)))); |
| |
| Set_Storage_Size_Variable (Ent, Entity_Id (V)); |
| end if; |
| |
| -- Other attributes require no expansion |
| |
| when others => |
| null; |
| |
| end case; |
| |
| end Expand_N_Attribute_Definition_Clause; |
| |
| ------------------------------------- |
| -- Expand_External_Tag_Definition -- |
| ------------------------------------- |
| |
| procedure Expand_External_Tag_Definition (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Ent : constant Entity_Id := Entity (Name (N)); |
| Old_Val : constant String_Id := Strval (Expr_Value_S (Expression (N))); |
| New_Val : String_Id; |
| E : Entity_Id; |
| |
| begin |
| -- For the rep clause "for x'external_tag use y" generate: |
| |
| -- xV : constant string := y; |
| -- Set_External_Tag (x'tag, xV'Address); |
| -- Register_Tag (x'tag); |
| |
| -- note that register_tag has been delayed up to now because |
| -- the external_tag must be set before registering. |
| |
| -- Create a new nul terminated string if it is not already |
| |
| if String_Length (Old_Val) > 0 |
| and then Get_String_Char (Old_Val, String_Length (Old_Val)) = 0 |
| then |
| New_Val := Old_Val; |
| else |
| Start_String (Old_Val); |
| Store_String_Char (Get_Char_Code (ASCII.NUL)); |
| New_Val := End_String; |
| end if; |
| |
| E := |
| Make_Defining_Identifier (Loc, |
| New_External_Name (Chars (Ent), 'A')); |
| |
| -- The generated actions must be elaborated at the subsequent |
| -- freeze point, not at the point of the attribute definition. |
| |
| Append_Freeze_Action (Ent, |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => E, |
| Constant_Present => True, |
| Object_Definition => |
| New_Reference_To (Standard_String, Loc), |
| Expression => |
| Make_String_Literal (Loc, Strval => New_Val))); |
| |
| Append_Freeze_Actions (Ent, New_List ( |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Reference_To (RTE (RE_Set_External_Tag), Loc), |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (Loc, |
| Attribute_Name => Name_Tag, |
| Prefix => New_Occurrence_Of (Ent, Loc)), |
| |
| Make_Attribute_Reference (Loc, |
| Attribute_Name => Name_Address, |
| Prefix => New_Occurrence_Of (E, Loc)))), |
| |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Reference_To (RTE (RE_Register_Tag), Loc), |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (Loc, |
| Attribute_Name => Name_Tag, |
| Prefix => New_Occurrence_Of (Ent, Loc)))))); |
| end Expand_External_Tag_Definition; |
| |
| ---------------------------- |
| -- Expand_N_Freeze_Entity -- |
| ---------------------------- |
| |
| procedure Expand_N_Freeze_Entity (N : Node_Id) is |
| E : constant Entity_Id := Entity (N); |
| E_Scope : Entity_Id; |
| S : Entity_Id; |
| In_Other_Scope : Boolean; |
| In_Outer_Scope : Boolean; |
| Decl : Node_Id; |
| Delete : Boolean := False; |
| |
| begin |
| -- For object, with address clause, check alignment is OK |
| |
| if Is_Object (E) then |
| Apply_Alignment_Check (E, N); |
| |
| -- Only other items requiring any front end action are |
| -- types and subprograms. |
| |
| elsif not Is_Type (E) and then not Is_Subprogram (E) then |
| return; |
| end if; |
| |
| -- Here E is a type or a subprogram |
| |
| E_Scope := Scope (E); |
| |
| -- This is an error protection against previous errors |
| |
| if No (E_Scope) then |
| return; |
| end if; |
| |
| -- If we are freezing entities defined in protected types, they |
| -- belong in the enclosing scope, given that the original type |
| -- has been expanded away. The same is true for entities in task types, |
| -- in particular the parameter records of entries (Entities in bodies |
| -- are all frozen within the body). If we are in the task body, this |
| -- is a proper scope. |
| |
| if Ekind (E_Scope) = E_Protected_Type |
| or else (Ekind (E_Scope) = E_Task_Type |
| and then not Has_Completion (E_Scope)) |
| then |
| E_Scope := Scope (E_Scope); |
| end if; |
| |
| S := Current_Scope; |
| while S /= Standard_Standard and then S /= E_Scope loop |
| S := Scope (S); |
| end loop; |
| |
| In_Other_Scope := not (S = E_Scope); |
| In_Outer_Scope := (not In_Other_Scope) and then (S /= Current_Scope); |
| |
| -- If the entity being frozen is defined in a scope that is not |
| -- currently on the scope stack, we must establish the proper |
| -- visibility before freezing the entity and related subprograms. |
| |
| if In_Other_Scope then |
| New_Scope (E_Scope); |
| Install_Visible_Declarations (E_Scope); |
| |
| if Ekind (E_Scope) = E_Package or else |
| Ekind (E_Scope) = E_Generic_Package or else |
| Is_Protected_Type (E_Scope) or else |
| Is_Task_Type (E_Scope) |
| then |
| Install_Private_Declarations (E_Scope); |
| end if; |
| |
| -- If the entity is in an outer scope, then that scope needs to |
| -- temporarily become the current scope so that operations created |
| -- during type freezing will be declared in the right scope and |
| -- can properly override any corresponding inherited operations. |
| |
| elsif In_Outer_Scope then |
| New_Scope (E_Scope); |
| end if; |
| |
| -- If type, freeze the type |
| |
| if Is_Type (E) then |
| Delete := Freeze_Type (N); |
| |
| -- And for enumeration type, build the enumeration tables |
| |
| if Is_Enumeration_Type (E) then |
| Build_Enumeration_Image_Tables (E, N); |
| |
| elsif Is_Tagged_Type (E) |
| and then Is_First_Subtype (E) |
| then |
| -- Check for a definition of External_Tag, whose expansion must |
| -- be delayed until the dispatch table is built. The clause |
| -- is considered only if it applies to this specific tagged |
| -- type, as opposed to one of its ancestors. |
| |
| declare |
| Def : constant Node_Id := |
| Get_Attribute_Definition_Clause |
| (E, Attribute_External_Tag); |
| |
| begin |
| if Present (Def) and then Entity (Name (Def)) = E then |
| Expand_External_Tag_Definition (Def); |
| end if; |
| end; |
| end if; |
| |
| -- If subprogram, freeze the subprogram |
| |
| elsif Is_Subprogram (E) then |
| Freeze_Subprogram (N); |
| end if; |
| |
| -- Analyze actions generated by freezing. The init_proc contains |
| -- source expressions that may raise constraint_error, and the |
| -- assignment procedure for complex types needs checks on individual |
| -- component assignments, but all other freezing actions should be |
| -- compiled with all checks off. |
| |
| if Present (Actions (N)) then |
| Decl := First (Actions (N)); |
| |
| while Present (Decl) loop |
| |
| if Nkind (Decl) = N_Subprogram_Body |
| and then (Is_Init_Proc (Defining_Entity (Decl)) |
| or else |
| Chars (Defining_Entity (Decl)) = Name_uAssign) |
| then |
| Analyze (Decl); |
| |
| -- A subprogram body created for a renaming_as_body completes |
| -- a previous declaration, which may be in a different scope. |
| -- Establish the proper scope before analysis. |
| |
| elsif Nkind (Decl) = N_Subprogram_Body |
| and then Present (Corresponding_Spec (Decl)) |
| and then Scope (Corresponding_Spec (Decl)) /= Current_Scope |
| then |
| New_Scope (Scope (Corresponding_Spec (Decl))); |
| Analyze (Decl, Suppress => All_Checks); |
| Pop_Scope; |
| |
| else |
| Analyze (Decl, Suppress => All_Checks); |
| end if; |
| |
| Next (Decl); |
| end loop; |
| end if; |
| |
| -- If we are to delete this N_Freeze_Entity, do so by rewriting so that |
| -- a loop on all nodes being inserted will work propertly. |
| |
| if Delete then |
| Rewrite (N, Make_Null_Statement (Sloc (N))); |
| end if; |
| |
| if In_Other_Scope then |
| if Ekind (Current_Scope) = E_Package then |
| End_Package_Scope (E_Scope); |
| else |
| End_Scope; |
| end if; |
| |
| elsif In_Outer_Scope then |
| Pop_Scope; |
| end if; |
| end Expand_N_Freeze_Entity; |
| |
| ------------------------------------------- |
| -- Expand_N_Record_Representation_Clause -- |
| ------------------------------------------- |
| |
| -- The only expansion required is for the case of a mod clause present, |
| -- which is removed, and translated into an alignment representation |
| -- clause inserted immediately after the record rep clause with any |
| -- initial pragmas inserted at the start of the component clause list. |
| |
| procedure Expand_N_Record_Representation_Clause (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Rectype : constant Entity_Id := Entity (Identifier (N)); |
| Mod_Val : Uint; |
| Citems : List_Id; |
| Repitem : Node_Id; |
| AtM_Nod : Node_Id; |
| |
| begin |
| if Present (Mod_Clause (N)) then |
| Mod_Val := Expr_Value (Expression (Mod_Clause (N))); |
| Citems := Pragmas_Before (Mod_Clause (N)); |
| |
| if Present (Citems) then |
| Append_List_To (Citems, Component_Clauses (N)); |
| Set_Component_Clauses (N, Citems); |
| end if; |
| |
| AtM_Nod := |
| Make_Attribute_Definition_Clause (Loc, |
| Name => New_Reference_To (Base_Type (Rectype), Loc), |
| Chars => Name_Alignment, |
| Expression => Make_Integer_Literal (Loc, Mod_Val)); |
| |
| Set_From_At_Mod (AtM_Nod); |
| Insert_After (N, AtM_Nod); |
| Set_Mod_Clause (N, Empty); |
| end if; |
| |
| -- If the record representation clause has no components, then |
| -- completely remove it. Note that we also have to remove |
| -- ourself from the Rep Item list. |
| |
| if Is_Empty_List (Component_Clauses (N)) then |
| if First_Rep_Item (Rectype) = N then |
| Set_First_Rep_Item (Rectype, Next_Rep_Item (N)); |
| else |
| Repitem := First_Rep_Item (Rectype); |
| while Present (Next_Rep_Item (Repitem)) loop |
| if Next_Rep_Item (Repitem) = N then |
| Set_Next_Rep_Item (Repitem, Next_Rep_Item (N)); |
| exit; |
| end if; |
| |
| Next_Rep_Item (Repitem); |
| end loop; |
| end if; |
| |
| Rewrite (N, |
| Make_Null_Statement (Loc)); |
| end if; |
| end Expand_N_Record_Representation_Clause; |
| |
| end Exp_Ch13; |
