------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
-- --
|
-- --
|
-- GNAT COMPILER COMPONENTS --
|
-- GNAT COMPILER COMPONENTS --
|
-- --
|
-- --
|
-- E X P _ C H 1 3 --
|
-- E X P _ C H 1 3 --
|
-- --
|
-- --
|
-- B o d y --
|
-- B o d y --
|
-- --
|
-- --
|
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
|
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
|
-- --
|
-- --
|
-- GNAT is free software; you can redistribute it and/or modify it under --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
-- 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 --
|
-- for more details. You should have received a copy of the GNU General --
|
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
-- http://www.gnu.org/licenses for a complete copy of the license. --
|
-- http://www.gnu.org/licenses for a complete copy of the license. --
|
-- --
|
-- --
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
-- --
|
-- --
|
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
|
|
with Atree; use Atree;
|
with Atree; use Atree;
|
with Checks; use Checks;
|
with Checks; use Checks;
|
with Einfo; use Einfo;
|
with Einfo; use Einfo;
|
with Exp_Ch3; use Exp_Ch3;
|
with Exp_Ch3; use Exp_Ch3;
|
with Exp_Ch6; use Exp_Ch6;
|
with Exp_Ch6; use Exp_Ch6;
|
with Exp_Imgv; use Exp_Imgv;
|
with Exp_Imgv; use Exp_Imgv;
|
with Exp_Tss; use Exp_Tss;
|
with Exp_Tss; use Exp_Tss;
|
with Exp_Util; use Exp_Util;
|
with Exp_Util; use Exp_Util;
|
with Namet; use Namet;
|
with Namet; use Namet;
|
with Nlists; use Nlists;
|
with Nlists; use Nlists;
|
with Nmake; use Nmake;
|
with Nmake; use Nmake;
|
with Opt; use Opt;
|
with Opt; use Opt;
|
with Rtsfind; use Rtsfind;
|
with Rtsfind; use Rtsfind;
|
with Sem; use Sem;
|
with Sem; use Sem;
|
with Sem_Ch7; use Sem_Ch7;
|
with Sem_Ch7; use Sem_Ch7;
|
with Sem_Ch8; use Sem_Ch8;
|
with Sem_Ch8; use Sem_Ch8;
|
with Sem_Eval; use Sem_Eval;
|
with Sem_Eval; use Sem_Eval;
|
with Sem_Util; use Sem_Util;
|
with Sem_Util; use Sem_Util;
|
with Sinfo; use Sinfo;
|
with Sinfo; use Sinfo;
|
with Snames; use Snames;
|
with Snames; use Snames;
|
with Stand; use Stand;
|
with Stand; use Stand;
|
with Tbuild; use Tbuild;
|
with Tbuild; use Tbuild;
|
with Uintp; use Uintp;
|
with Uintp; use Uintp;
|
|
|
package body Exp_Ch13 is
|
package body Exp_Ch13 is
|
|
|
------------------------------------------
|
------------------------------------------
|
-- Expand_N_Attribute_Definition_Clause --
|
-- Expand_N_Attribute_Definition_Clause --
|
------------------------------------------
|
------------------------------------------
|
|
|
-- Expansion action depends on attribute involved
|
-- Expansion action depends on attribute involved
|
|
|
procedure Expand_N_Attribute_Definition_Clause (N : Node_Id) is
|
procedure Expand_N_Attribute_Definition_Clause (N : Node_Id) is
|
Loc : constant Source_Ptr := Sloc (N);
|
Loc : constant Source_Ptr := Sloc (N);
|
Exp : constant Node_Id := Expression (N);
|
Exp : constant Node_Id := Expression (N);
|
Ent : Entity_Id;
|
Ent : Entity_Id;
|
V : Node_Id;
|
V : Node_Id;
|
|
|
begin
|
begin
|
Ent := Entity (Name (N));
|
Ent := Entity (Name (N));
|
|
|
if Is_Type (Ent) then
|
if Is_Type (Ent) then
|
Ent := Underlying_Type (Ent);
|
Ent := Underlying_Type (Ent);
|
end if;
|
end if;
|
|
|
case Get_Attribute_Id (Chars (N)) is
|
case Get_Attribute_Id (Chars (N)) is
|
|
|
-------------
|
-------------
|
-- Address --
|
-- Address --
|
-------------
|
-------------
|
|
|
when Attribute_Address =>
|
when Attribute_Address =>
|
|
|
-- If there is an initialization which did not come from the
|
-- If there is an initialization which did not come from the
|
-- source program, then it is an artifact of our expansion, and we
|
-- source program, then it is an artifact of our expansion, and we
|
-- suppress it. The case we are most concerned about here is the
|
-- suppress it. The case we are most concerned about here is the
|
-- initialization of a packed array to all false, which seems
|
-- initialization of a packed array to all false, which seems
|
-- inappropriate for variable to which an address clause is
|
-- inappropriate for variable to which an address clause is
|
-- applied. The expression may itself have been rewritten if the
|
-- applied. The expression may itself have been rewritten if the
|
-- type is packed array, so we need to examine whether the
|
-- type is packed array, so we need to examine whether the
|
-- original node is in the source. An exception though is the case
|
-- original node is in the source. An exception though is the case
|
-- of an access variable which is default initialized to null, and
|
-- of an access variable which is default initialized to null, and
|
-- such initialization is retained.
|
-- such initialization is retained.
|
|
|
-- Furthermore, if the initialization is the equivalent aggregate
|
-- Furthermore, if the initialization is the equivalent aggregate
|
-- of the type initialization procedure, it replaces an implicit
|
-- of the type initialization procedure, it replaces an implicit
|
-- call to the init proc, and must be respected. Note that for
|
-- call to the init proc, and must be respected. Note that for
|
-- packed types we do not build equivalent aggregates.
|
-- packed types we do not build equivalent aggregates.
|
|
|
-- Also, if Init_Or_Norm_Scalars applies, then we need to retain
|
-- Also, if Init_Or_Norm_Scalars applies, then we need to retain
|
-- any default initialization for objects of scalar types and
|
-- any default initialization for objects of scalar types and
|
-- types with scalar components. Normally a composite type will
|
-- types with scalar components. Normally a composite type will
|
-- have an init_proc in the presence of Init_Or_Norm_Scalars,
|
-- have an init_proc in the presence of Init_Or_Norm_Scalars,
|
-- so when that flag is set we have just have to do a test for
|
-- so when that flag is set we have just have to do a test for
|
-- scalar and string types (the predefined string types such as
|
-- scalar and string types (the predefined string types such as
|
-- String and Wide_String don't have an init_proc).
|
-- String and Wide_String don't have an init_proc).
|
|
|
declare
|
declare
|
Decl : constant Node_Id := Declaration_Node (Ent);
|
Decl : constant Node_Id := Declaration_Node (Ent);
|
Typ : constant Entity_Id := Etype (Ent);
|
Typ : constant Entity_Id := Etype (Ent);
|
|
|
begin
|
begin
|
if Nkind (Decl) = N_Object_Declaration
|
if Nkind (Decl) = N_Object_Declaration
|
and then Present (Expression (Decl))
|
and then Present (Expression (Decl))
|
and then Nkind (Expression (Decl)) /= N_Null
|
and then Nkind (Expression (Decl)) /= N_Null
|
and then
|
and then
|
not Comes_From_Source (Original_Node (Expression (Decl)))
|
not Comes_From_Source (Original_Node (Expression (Decl)))
|
then
|
then
|
if Present (Base_Init_Proc (Typ))
|
if Present (Base_Init_Proc (Typ))
|
and then
|
and then
|
Present (Static_Initialization (Base_Init_Proc (Typ)))
|
Present (Static_Initialization (Base_Init_Proc (Typ)))
|
then
|
then
|
null;
|
null;
|
|
|
elsif Init_Or_Norm_Scalars
|
elsif Init_Or_Norm_Scalars
|
and then
|
and then
|
(Is_Scalar_Type (Typ) or else Is_String_Type (Typ))
|
(Is_Scalar_Type (Typ) or else Is_String_Type (Typ))
|
then
|
then
|
null;
|
null;
|
|
|
else
|
else
|
Set_Expression (Decl, Empty);
|
Set_Expression (Decl, Empty);
|
end if;
|
end if;
|
end if;
|
end if;
|
end;
|
end;
|
|
|
---------------
|
---------------
|
-- Alignment --
|
-- Alignment --
|
---------------
|
---------------
|
|
|
when Attribute_Alignment =>
|
when Attribute_Alignment =>
|
|
|
-- As required by Gigi, we guarantee that the operand is an
|
-- As required by Gigi, we guarantee that the operand is an
|
-- integer literal (this simplifies things in Gigi).
|
-- integer literal (this simplifies things in Gigi).
|
|
|
if Nkind (Exp) /= N_Integer_Literal then
|
if Nkind (Exp) /= N_Integer_Literal then
|
Rewrite
|
Rewrite
|
(Exp, Make_Integer_Literal (Loc, Expr_Value (Exp)));
|
(Exp, Make_Integer_Literal (Loc, Expr_Value (Exp)));
|
end if;
|
end if;
|
|
|
------------------
|
------------------
|
-- Storage_Size --
|
-- Storage_Size --
|
------------------
|
------------------
|
|
|
when Attribute_Storage_Size =>
|
when Attribute_Storage_Size =>
|
|
|
-- If the type is a task type, then assign the value of the
|
-- If the type is a task type, then assign the value of the
|
-- storage size to the Size variable associated with the task.
|
-- storage size to the Size variable associated with the task.
|
-- task_typeZ := expression
|
-- task_typeZ := expression
|
|
|
if Ekind (Ent) = E_Task_Type then
|
if Ekind (Ent) = E_Task_Type then
|
Insert_Action (N,
|
Insert_Action (N,
|
Make_Assignment_Statement (Loc,
|
Make_Assignment_Statement (Loc,
|
Name => New_Reference_To (Storage_Size_Variable (Ent), Loc),
|
Name => New_Reference_To (Storage_Size_Variable (Ent), Loc),
|
Expression =>
|
Expression =>
|
Convert_To (RTE (RE_Size_Type), Expression (N))));
|
Convert_To (RTE (RE_Size_Type), Expression (N))));
|
|
|
-- For Storage_Size for an access type, create a variable to hold
|
-- For Storage_Size for an access type, create a variable to hold
|
-- the value of the specified size with name typeV and expand an
|
-- the value of the specified size with name typeV and expand an
|
-- assignment statement to initialize this value.
|
-- assignment statement to initialize this value.
|
|
|
elsif Is_Access_Type (Ent) then
|
elsif Is_Access_Type (Ent) then
|
|
|
-- We don't need the variable for a storage size of zero
|
-- We don't need the variable for a storage size of zero
|
|
|
if not No_Pool_Assigned (Ent) then
|
if not No_Pool_Assigned (Ent) then
|
V :=
|
V :=
|
Make_Defining_Identifier (Loc,
|
Make_Defining_Identifier (Loc,
|
Chars => New_External_Name (Chars (Ent), 'V'));
|
Chars => New_External_Name (Chars (Ent), 'V'));
|
|
|
-- Insert the declaration of the object
|
-- Insert the declaration of the object
|
|
|
Insert_Action (N,
|
Insert_Action (N,
|
Make_Object_Declaration (Loc,
|
Make_Object_Declaration (Loc,
|
Defining_Identifier => V,
|
Defining_Identifier => V,
|
Object_Definition =>
|
Object_Definition =>
|
New_Reference_To (RTE (RE_Storage_Offset), Loc),
|
New_Reference_To (RTE (RE_Storage_Offset), Loc),
|
Expression =>
|
Expression =>
|
Convert_To (RTE (RE_Storage_Offset), Expression (N))));
|
Convert_To (RTE (RE_Storage_Offset), Expression (N))));
|
|
|
Set_Storage_Size_Variable (Ent, Entity_Id (V));
|
Set_Storage_Size_Variable (Ent, Entity_Id (V));
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
-- Other attributes require no expansion
|
-- Other attributes require no expansion
|
|
|
when others =>
|
when others =>
|
null;
|
null;
|
|
|
end case;
|
end case;
|
end Expand_N_Attribute_Definition_Clause;
|
end Expand_N_Attribute_Definition_Clause;
|
|
|
----------------------------
|
----------------------------
|
-- Expand_N_Freeze_Entity --
|
-- Expand_N_Freeze_Entity --
|
----------------------------
|
----------------------------
|
|
|
procedure Expand_N_Freeze_Entity (N : Node_Id) is
|
procedure Expand_N_Freeze_Entity (N : Node_Id) is
|
E : constant Entity_Id := Entity (N);
|
E : constant Entity_Id := Entity (N);
|
E_Scope : Entity_Id;
|
E_Scope : Entity_Id;
|
S : Entity_Id;
|
S : Entity_Id;
|
In_Other_Scope : Boolean;
|
In_Other_Scope : Boolean;
|
In_Outer_Scope : Boolean;
|
In_Outer_Scope : Boolean;
|
Decl : Node_Id;
|
Decl : Node_Id;
|
Delete : Boolean := False;
|
Delete : Boolean := False;
|
|
|
begin
|
begin
|
-- Processing for objects with address clauses
|
-- Processing for objects with address clauses
|
|
|
if Is_Object (E) and then Present (Address_Clause (E)) then
|
if Is_Object (E) and then Present (Address_Clause (E)) then
|
Apply_Address_Clause_Check (E, N);
|
Apply_Address_Clause_Check (E, N);
|
return;
|
return;
|
|
|
-- Only other items requiring any front end action are types and
|
-- Only other items requiring any front end action are types and
|
-- subprograms.
|
-- subprograms.
|
|
|
elsif not Is_Type (E) and then not Is_Subprogram (E) then
|
elsif not Is_Type (E) and then not Is_Subprogram (E) then
|
return;
|
return;
|
end if;
|
end if;
|
|
|
-- Here E is a type or a subprogram
|
-- Here E is a type or a subprogram
|
|
|
E_Scope := Scope (E);
|
E_Scope := Scope (E);
|
|
|
-- This is an error protection against previous errors
|
-- This is an error protection against previous errors
|
|
|
if No (E_Scope) then
|
if No (E_Scope) then
|
return;
|
return;
|
end if;
|
end if;
|
|
|
-- Remember that we are processing a freezing entity and its freezing
|
-- Remember that we are processing a freezing entity and its freezing
|
-- nodes. This flag (non-zero = set) is used to avoid the need of
|
-- nodes. This flag (non-zero = set) is used to avoid the need of
|
-- climbing through the tree while processing the freezing actions (ie.
|
-- climbing through the tree while processing the freezing actions (ie.
|
-- to avoid generating spurious warnings or to avoid killing constant
|
-- to avoid generating spurious warnings or to avoid killing constant
|
-- indications while processing the code associated with freezing
|
-- indications while processing the code associated with freezing
|
-- actions). We use a counter to deal with nesting.
|
-- actions). We use a counter to deal with nesting.
|
|
|
Inside_Freezing_Actions := Inside_Freezing_Actions + 1;
|
Inside_Freezing_Actions := Inside_Freezing_Actions + 1;
|
|
|
-- If we are freezing entities defined in protected types, they belong
|
-- If we are freezing entities defined in protected types, they belong
|
-- in the enclosing scope, given that the original type has been
|
-- in the enclosing scope, given that the original type has been
|
-- expanded away. The same is true for entities in task types, in
|
-- expanded away. The same is true for entities in task types, in
|
-- particular the parameter records of entries (Entities in bodies are
|
-- 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
|
-- all frozen within the body). If we are in the task body, this is a
|
-- proper scope. If we are within a subprogram body, the proper scope
|
-- proper scope. If we are within a subprogram body, the proper scope
|
-- is the corresponding spec. This may happen for itypes generated in
|
-- is the corresponding spec. This may happen for itypes generated in
|
-- the bodies of protected operations.
|
-- the bodies of protected operations.
|
|
|
if Ekind (E_Scope) = E_Protected_Type
|
if Ekind (E_Scope) = E_Protected_Type
|
or else (Ekind (E_Scope) = E_Task_Type
|
or else (Ekind (E_Scope) = E_Task_Type
|
and then not Has_Completion (E_Scope))
|
and then not Has_Completion (E_Scope))
|
then
|
then
|
E_Scope := Scope (E_Scope);
|
E_Scope := Scope (E_Scope);
|
|
|
elsif Ekind (E_Scope) = E_Subprogram_Body then
|
elsif Ekind (E_Scope) = E_Subprogram_Body then
|
E_Scope := Corresponding_Spec (Unit_Declaration_Node (E_Scope));
|
E_Scope := Corresponding_Spec (Unit_Declaration_Node (E_Scope));
|
end if;
|
end if;
|
|
|
S := Current_Scope;
|
S := Current_Scope;
|
while S /= Standard_Standard and then S /= E_Scope loop
|
while S /= Standard_Standard and then S /= E_Scope loop
|
S := Scope (S);
|
S := Scope (S);
|
end loop;
|
end loop;
|
|
|
In_Other_Scope := not (S = E_Scope);
|
In_Other_Scope := not (S = E_Scope);
|
In_Outer_Scope := (not In_Other_Scope) and then (S /= Current_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
|
-- If the entity being frozen is defined in a scope that is not
|
-- currently on the scope stack, we must establish the proper
|
-- currently on the scope stack, we must establish the proper
|
-- visibility before freezing the entity and related subprograms.
|
-- visibility before freezing the entity and related subprograms.
|
|
|
if In_Other_Scope then
|
if In_Other_Scope then
|
Push_Scope (E_Scope);
|
Push_Scope (E_Scope);
|
Install_Visible_Declarations (E_Scope);
|
Install_Visible_Declarations (E_Scope);
|
|
|
if Is_Package_Or_Generic_Package (E_Scope) or else
|
if Is_Package_Or_Generic_Package (E_Scope) or else
|
Is_Protected_Type (E_Scope) or else
|
Is_Protected_Type (E_Scope) or else
|
Is_Task_Type (E_Scope)
|
Is_Task_Type (E_Scope)
|
then
|
then
|
Install_Private_Declarations (E_Scope);
|
Install_Private_Declarations (E_Scope);
|
end if;
|
end if;
|
|
|
-- If the entity is in an outer scope, then that scope needs to
|
-- If the entity is in an outer scope, then that scope needs to
|
-- temporarily become the current scope so that operations created
|
-- temporarily become the current scope so that operations created
|
-- during type freezing will be declared in the right scope and
|
-- during type freezing will be declared in the right scope and
|
-- can properly override any corresponding inherited operations.
|
-- can properly override any corresponding inherited operations.
|
|
|
elsif In_Outer_Scope then
|
elsif In_Outer_Scope then
|
Push_Scope (E_Scope);
|
Push_Scope (E_Scope);
|
end if;
|
end if;
|
|
|
-- If type, freeze the type
|
-- If type, freeze the type
|
|
|
if Is_Type (E) then
|
if Is_Type (E) then
|
Delete := Freeze_Type (N);
|
Delete := Freeze_Type (N);
|
|
|
-- And for enumeration type, build the enumeration tables
|
-- And for enumeration type, build the enumeration tables
|
|
|
if Is_Enumeration_Type (E) then
|
if Is_Enumeration_Type (E) then
|
Build_Enumeration_Image_Tables (E, N);
|
Build_Enumeration_Image_Tables (E, N);
|
end if;
|
end if;
|
|
|
-- If subprogram, freeze the subprogram
|
-- If subprogram, freeze the subprogram
|
|
|
elsif Is_Subprogram (E) then
|
elsif Is_Subprogram (E) then
|
Freeze_Subprogram (N);
|
Freeze_Subprogram (N);
|
|
|
-- Ada 2005 (AI-251): Remove the freezing node associated with the
|
-- Ada 2005 (AI-251): Remove the freezing node associated with the
|
-- entities internally used by the frontend to register primitives
|
-- entities internally used by the frontend to register primitives
|
-- covering abstract interfaces. The call to Freeze_Subprogram has
|
-- covering abstract interfaces. The call to Freeze_Subprogram has
|
-- already expanded the code that fills the corresponding entry in
|
-- already expanded the code that fills the corresponding entry in
|
-- its secondary dispatch table and therefore the code generator
|
-- its secondary dispatch table and therefore the code generator
|
-- has nothing else to do with this freezing node.
|
-- has nothing else to do with this freezing node.
|
|
|
Delete := Present (Interface_Alias (E));
|
Delete := Present (Interface_Alias (E));
|
end if;
|
end if;
|
|
|
-- Analyze actions generated by freezing. The init_proc contains source
|
-- Analyze actions generated by freezing. The init_proc contains source
|
-- expressions that may raise Constraint_Error, and the assignment
|
-- expressions that may raise Constraint_Error, and the assignment
|
-- procedure for complex types needs checks on individual component
|
-- procedure for complex types needs checks on individual component
|
-- assignments, but all other freezing actions should be compiled with
|
-- assignments, but all other freezing actions should be compiled with
|
-- all checks off.
|
-- all checks off.
|
|
|
if Present (Actions (N)) then
|
if Present (Actions (N)) then
|
Decl := First (Actions (N));
|
Decl := First (Actions (N));
|
while Present (Decl) loop
|
while Present (Decl) loop
|
if Nkind (Decl) = N_Subprogram_Body
|
if Nkind (Decl) = N_Subprogram_Body
|
and then (Is_Init_Proc (Defining_Entity (Decl))
|
and then (Is_Init_Proc (Defining_Entity (Decl))
|
or else
|
or else
|
Chars (Defining_Entity (Decl)) = Name_uAssign)
|
Chars (Defining_Entity (Decl)) = Name_uAssign)
|
then
|
then
|
Analyze (Decl);
|
Analyze (Decl);
|
|
|
-- A subprogram body created for a renaming_as_body completes
|
-- A subprogram body created for a renaming_as_body completes
|
-- a previous declaration, which may be in a different scope.
|
-- a previous declaration, which may be in a different scope.
|
-- Establish the proper scope before analysis.
|
-- Establish the proper scope before analysis.
|
|
|
elsif Nkind (Decl) = N_Subprogram_Body
|
elsif Nkind (Decl) = N_Subprogram_Body
|
and then Present (Corresponding_Spec (Decl))
|
and then Present (Corresponding_Spec (Decl))
|
and then Scope (Corresponding_Spec (Decl)) /= Current_Scope
|
and then Scope (Corresponding_Spec (Decl)) /= Current_Scope
|
then
|
then
|
Push_Scope (Scope (Corresponding_Spec (Decl)));
|
Push_Scope (Scope (Corresponding_Spec (Decl)));
|
Analyze (Decl, Suppress => All_Checks);
|
Analyze (Decl, Suppress => All_Checks);
|
Pop_Scope;
|
Pop_Scope;
|
|
|
else
|
else
|
Analyze (Decl, Suppress => All_Checks);
|
Analyze (Decl, Suppress => All_Checks);
|
end if;
|
end if;
|
|
|
Next (Decl);
|
Next (Decl);
|
end loop;
|
end loop;
|
end if;
|
end if;
|
|
|
-- If we are to delete this N_Freeze_Entity, do so by rewriting so that
|
-- 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.
|
-- a loop on all nodes being inserted will work propertly.
|
|
|
if Delete then
|
if Delete then
|
Rewrite (N, Make_Null_Statement (Sloc (N)));
|
Rewrite (N, Make_Null_Statement (Sloc (N)));
|
end if;
|
end if;
|
|
|
if In_Other_Scope then
|
if In_Other_Scope then
|
if Ekind (Current_Scope) = E_Package then
|
if Ekind (Current_Scope) = E_Package then
|
End_Package_Scope (E_Scope);
|
End_Package_Scope (E_Scope);
|
else
|
else
|
End_Scope;
|
End_Scope;
|
end if;
|
end if;
|
|
|
elsif In_Outer_Scope then
|
elsif In_Outer_Scope then
|
Pop_Scope;
|
Pop_Scope;
|
end if;
|
end if;
|
|
|
-- Restore previous value of the nesting-level counter that records
|
-- Restore previous value of the nesting-level counter that records
|
-- whether we are inside a (possibly nested) call to this procedure.
|
-- whether we are inside a (possibly nested) call to this procedure.
|
|
|
Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
|
Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
|
end Expand_N_Freeze_Entity;
|
end Expand_N_Freeze_Entity;
|
|
|
-------------------------------------------
|
-------------------------------------------
|
-- Expand_N_Record_Representation_Clause --
|
-- Expand_N_Record_Representation_Clause --
|
-------------------------------------------
|
-------------------------------------------
|
|
|
-- The only expansion required is for the case of a mod clause present,
|
-- The only expansion required is for the case of a mod clause present,
|
-- which is removed, and translated into an alignment representation
|
-- which is removed, and translated into an alignment representation
|
-- clause inserted immediately after the record rep clause with any
|
-- clause inserted immediately after the record rep clause with any
|
-- initial pragmas inserted at the start of the component clause list.
|
-- initial pragmas inserted at the start of the component clause list.
|
|
|
procedure Expand_N_Record_Representation_Clause (N : Node_Id) is
|
procedure Expand_N_Record_Representation_Clause (N : Node_Id) is
|
Loc : constant Source_Ptr := Sloc (N);
|
Loc : constant Source_Ptr := Sloc (N);
|
Rectype : constant Entity_Id := Entity (Identifier (N));
|
Rectype : constant Entity_Id := Entity (Identifier (N));
|
Mod_Val : Uint;
|
Mod_Val : Uint;
|
Citems : List_Id;
|
Citems : List_Id;
|
Repitem : Node_Id;
|
Repitem : Node_Id;
|
AtM_Nod : Node_Id;
|
AtM_Nod : Node_Id;
|
|
|
begin
|
begin
|
if Present (Mod_Clause (N)) and then not Ignore_Rep_Clauses then
|
if Present (Mod_Clause (N)) and then not Ignore_Rep_Clauses then
|
Mod_Val := Expr_Value (Expression (Mod_Clause (N)));
|
Mod_Val := Expr_Value (Expression (Mod_Clause (N)));
|
Citems := Pragmas_Before (Mod_Clause (N));
|
Citems := Pragmas_Before (Mod_Clause (N));
|
|
|
if Present (Citems) then
|
if Present (Citems) then
|
Append_List_To (Citems, Component_Clauses (N));
|
Append_List_To (Citems, Component_Clauses (N));
|
Set_Component_Clauses (N, Citems);
|
Set_Component_Clauses (N, Citems);
|
end if;
|
end if;
|
|
|
AtM_Nod :=
|
AtM_Nod :=
|
Make_Attribute_Definition_Clause (Loc,
|
Make_Attribute_Definition_Clause (Loc,
|
Name => New_Reference_To (Base_Type (Rectype), Loc),
|
Name => New_Reference_To (Base_Type (Rectype), Loc),
|
Chars => Name_Alignment,
|
Chars => Name_Alignment,
|
Expression => Make_Integer_Literal (Loc, Mod_Val));
|
Expression => Make_Integer_Literal (Loc, Mod_Val));
|
|
|
Set_From_At_Mod (AtM_Nod);
|
Set_From_At_Mod (AtM_Nod);
|
Insert_After (N, AtM_Nod);
|
Insert_After (N, AtM_Nod);
|
Set_Mod_Clause (N, Empty);
|
Set_Mod_Clause (N, Empty);
|
end if;
|
end if;
|
|
|
-- If the record representation clause has no components, then
|
-- If the record representation clause has no components, then
|
-- completely remove it. Note that we also have to remove
|
-- completely remove it. Note that we also have to remove
|
-- ourself from the Rep Item list.
|
-- ourself from the Rep Item list.
|
|
|
if Is_Empty_List (Component_Clauses (N)) then
|
if Is_Empty_List (Component_Clauses (N)) then
|
if First_Rep_Item (Rectype) = N then
|
if First_Rep_Item (Rectype) = N then
|
Set_First_Rep_Item (Rectype, Next_Rep_Item (N));
|
Set_First_Rep_Item (Rectype, Next_Rep_Item (N));
|
else
|
else
|
Repitem := First_Rep_Item (Rectype);
|
Repitem := First_Rep_Item (Rectype);
|
while Present (Next_Rep_Item (Repitem)) loop
|
while Present (Next_Rep_Item (Repitem)) loop
|
if Next_Rep_Item (Repitem) = N then
|
if Next_Rep_Item (Repitem) = N then
|
Set_Next_Rep_Item (Repitem, Next_Rep_Item (N));
|
Set_Next_Rep_Item (Repitem, Next_Rep_Item (N));
|
exit;
|
exit;
|
end if;
|
end if;
|
|
|
Next_Rep_Item (Repitem);
|
Next_Rep_Item (Repitem);
|
end loop;
|
end loop;
|
end if;
|
end if;
|
|
|
Rewrite (N,
|
Rewrite (N,
|
Make_Null_Statement (Loc));
|
Make_Null_Statement (Loc));
|
end if;
|
end if;
|
end Expand_N_Record_Representation_Clause;
|
end Expand_N_Record_Representation_Clause;
|
|
|
end Exp_Ch13;
|
end Exp_Ch13;
|
|
|