diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/exp_ch13.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/exp_ch13.adb | 473 |
1 files changed, 0 insertions, 473 deletions
diff --git a/gcc-4.2.1/gcc/ada/exp_ch13.adb b/gcc-4.2.1/gcc/ada/exp_ch13.adb deleted file mode 100644 index fd40084fb..000000000 --- a/gcc-4.2.1/gcc/ada/exp_ch13.adb +++ /dev/null @@ -1,473 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; |