------------------------------------------------------------------------------ -- -- -- 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, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, 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;