-- --
-- $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- --
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 --
------------------------------------------
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 --
------------------
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 --
----------------------------
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
OSDN Git Service
