diff options
Diffstat (limited to 'gcc/ada/exp_ch13.adb')
| -rw-r--r-- | gcc/ada/exp_ch13.adb | 157 |
1 files changed, 92 insertions, 65 deletions
diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index bbc8458eff5..b1e24128c0b 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -8,7 +8,7 @@ -- -- -- $Revision$ -- -- --- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2002, 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- -- @@ -50,6 +50,11 @@ 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 -- ------------------------------------------ @@ -115,70 +120,6 @@ package body Exp_Ch13 is end if; ------------------ - -- External_Tag -- - ------------------ - - -- 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 resistering. - - when Attribute_External_Tag => External_Tag : declare - E : Entity_Id; - Old_Val : String_Id := Strval (Expr_Value_S (Exp)); - New_Val : String_Id; - - begin - -- 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')); - - Insert_Action (N, - 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))); - - Insert_Actions (N, 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 External_Tag; - - ------------------ -- Storage_Size -- ------------------ @@ -224,6 +165,76 @@ package body Exp_Ch13 is 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)); + E : Entity_Id; + Old_Val : String_Id := Strval (Expr_Value_S (Expression (N))); + New_Val : String_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 -- ---------------------------- @@ -309,6 +320,22 @@ package body Exp_Ch13 is 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. + + declare + Def : Node_Id := + Get_Attribute_Definition_Clause (E, Attribute_External_Tag); + begin + if Present (Def) then + Expand_External_Tag_Definition (Def); + end if; + end; end if; -- If subprogram, freeze the subprogram |