[multiple changes]
2009-06-21 Thomas Quinot <quinot@adacore.com> * exp_ch3.adb, exp_prag.adb, exp_util.adb, exp_util.ads, freeze.adb, sem_ch13.adb, sem_elab.adb (Exp_Prag.Expand_Pragma_Import_Or_Interface): Factor out code to new subprogram... (Exp_Util.Find_Init_Call): New shared routine to find the init proc call for a default initialized variable. (Freeze.Check_Address_Clause): Do not reset Has_Delayed_Freeze on an entity that has an associated freeze node. (Sem_Ch13.Analyze_Attribute_Definition_Clause, case Address): If there is an init call for the object, defer it to the object freeze point. (Check_Elab_Call.Find_Init_Call): Rename to Check_Init_Call, to avoid name clash with new subprogram introduced in Exp_Util. 2009-06-21 Robert Dewar <dewar@adacore.com> * einfo.ads: Minor reformatting From-SVN: r148764
This commit is contained in:
Arnaud Charlet
parent
4f91a2557f
commit
f3b57ab079
|
|
@ -1,3 +1,22 @@
|
|||
2009-06-21 Thomas Quinot <quinot@adacore.com>
|
||||
|
||||
* exp_ch3.adb, exp_prag.adb, exp_util.adb, exp_util.ads, freeze.adb,
|
||||
sem_ch13.adb, sem_elab.adb (Exp_Prag.Expand_Pragma_Import_Or_Interface):
|
||||
Factor out code to new subprogram...
|
||||
(Exp_Util.Find_Init_Call): New shared routine to find the init proc call
|
||||
for a default initialized variable.
|
||||
(Freeze.Check_Address_Clause): Do not reset Has_Delayed_Freeze on an
|
||||
entity that has an associated freeze node.
|
||||
(Sem_Ch13.Analyze_Attribute_Definition_Clause, case Address):
|
||||
If there is an init call for the object, defer it to the object freeze
|
||||
point.
|
||||
(Check_Elab_Call.Find_Init_Call): Rename to Check_Init_Call, to avoid
|
||||
name clash with new subprogram introduced in Exp_Util.
|
||||
|
||||
2009-06-21 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* einfo.ads: Minor reformatting
|
||||
|
||||
2009-06-21 Ed Falis <falis@adacore.com>
|
||||
|
||||
* env.c (__gnat_environ): return NULL for vThreads - unimplemented
|
||||
|
|
|
|||
|
|
@ -241,7 +241,7 @@ package Einfo is
|
|||
|
||||
-- For elementary types other than discrete and fixed-point types, the
|
||||
-- Object_Size and Value_Size are the same (and equivalent to the RM
|
||||
-- attribute Size). Only Size may be specified for such types.
|
||||
-- attribute Size). Only Size may be specified for such types.
|
||||
|
||||
-- For composite types, Object_Size and Value_Size are computed from their
|
||||
-- respective value for the type of each element as well as the layout.
|
||||
|
|
|
|||
|
|
@ -4380,8 +4380,12 @@ package body Exp_Ch3 is
|
|||
-- object being initialized. This is because the call is not a
|
||||
-- source level call. This works fine, because the only possible
|
||||
-- statements depending on freeze status that can appear after the
|
||||
-- _Init call are rep clauses which can safely appear after actual
|
||||
-- references to the object.
|
||||
-- Init_Proc call are rep clauses which can safely appear after
|
||||
-- actual references to the object. Note that this call may
|
||||
-- subsequently be removed (if a pragma Import is encountered),
|
||||
-- or moved to the freeze actions for the object (e.g. if an
|
||||
-- address clause is applied to the object, causing it to get
|
||||
-- delayed freezing).
|
||||
|
||||
Id_Ref := New_Reference_To (Def_Id, Loc);
|
||||
Set_Must_Not_Freeze (Id_Ref);
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2008, 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 --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
|
|
@ -29,7 +29,6 @@ with Debug; use Debug;
|
|||
with Einfo; use Einfo;
|
||||
with Errout; use Errout;
|
||||
with Exp_Ch11; use Exp_Ch11;
|
||||
with Exp_Tss; use Exp_Tss;
|
||||
with Exp_Util; use Exp_Util;
|
||||
with Expander; use Expander;
|
||||
with Namet; use Namet;
|
||||
|
|
@ -485,29 +484,17 @@ package body Exp_Prag is
|
|||
|
||||
procedure Expand_Pragma_Import_Or_Interface (N : Node_Id) is
|
||||
Def_Id : constant Entity_Id := Entity (Arg2 (N));
|
||||
Typ : Entity_Id;
|
||||
Init_Call : Node_Id;
|
||||
|
||||
begin
|
||||
if Ekind (Def_Id) = E_Variable then
|
||||
Typ := Etype (Def_Id);
|
||||
|
||||
-- Iterate from declaration of object to import pragma, to find
|
||||
-- generated initialization call for object, if any.
|
||||
-- Find generated initialization call for object, if any
|
||||
|
||||
Init_Call := Next (Parent (Def_Id));
|
||||
while Present (Init_Call) and then Init_Call /= N loop
|
||||
if Has_Non_Null_Base_Init_Proc (Typ)
|
||||
and then Nkind (Init_Call) = N_Procedure_Call_Statement
|
||||
and then Is_Entity_Name (Name (Init_Call))
|
||||
and then Entity (Name (Init_Call)) = Base_Init_Proc (Typ)
|
||||
then
|
||||
Remove (Init_Call);
|
||||
exit;
|
||||
else
|
||||
Next (Init_Call);
|
||||
end if;
|
||||
end loop;
|
||||
Init_Call := Find_Init_Call (Def_Id, Rep_Clause => N);
|
||||
if Present (Init_Call) then
|
||||
Remove (Init_Call);
|
||||
end if;
|
||||
|
||||
-- Any default initialization expression should be removed
|
||||
-- (e.g., null defaults for access objects, zero initialization
|
||||
|
|
@ -515,9 +502,7 @@ package body Exp_Prag is
|
|||
-- have explicit initialization, so the expression must have
|
||||
-- been generated by the compiler.
|
||||
|
||||
if Init_Call = N
|
||||
and then Present (Expression (Parent (Def_Id)))
|
||||
then
|
||||
if No (Init_Call) and then Present (Expression (Parent (Def_Id))) then
|
||||
Set_Expression (Parent (Def_Id), Empty);
|
||||
end if;
|
||||
end if;
|
||||
|
|
|
|||
|
|
@ -1398,6 +1398,74 @@ package body Exp_Util is
|
|||
end if;
|
||||
end Expand_Subtype_From_Expr;
|
||||
|
||||
--------------------
|
||||
-- Find_Init_Call --
|
||||
--------------------
|
||||
|
||||
function Find_Init_Call
|
||||
(Var : Entity_Id;
|
||||
Rep_Clause : Node_Id) return Node_Id
|
||||
is
|
||||
Typ : constant Entity_Id := Etype (Var);
|
||||
|
||||
Init_Proc : Entity_Id;
|
||||
-- Initialization procedure for Typ
|
||||
|
||||
function Find_Init_Call_In_List (From : Node_Id) return Node_Id;
|
||||
-- Look for init call for Var starting at From and scanning the
|
||||
-- enclosing list until Rep_Clause or the end of the list is reached.
|
||||
|
||||
----------------------------
|
||||
-- Find_Init_Call_In_List --
|
||||
----------------------------
|
||||
|
||||
function Find_Init_Call_In_List (From : Node_Id) return Node_Id is
|
||||
Init_Call : Node_Id;
|
||||
begin
|
||||
Init_Call := From;
|
||||
|
||||
while Present (Init_Call) and then Init_Call /= Rep_Clause loop
|
||||
if Nkind (Init_Call) = N_Procedure_Call_Statement
|
||||
and then Is_Entity_Name (Name (Init_Call))
|
||||
and then Entity (Name (Init_Call)) = Init_Proc
|
||||
then
|
||||
return Init_Call;
|
||||
end if;
|
||||
Next (Init_Call);
|
||||
end loop;
|
||||
|
||||
return Empty;
|
||||
end Find_Init_Call_In_List;
|
||||
|
||||
Init_Call : Node_Id;
|
||||
|
||||
-- Start of processing for Find_Init_Call
|
||||
|
||||
begin
|
||||
if not Has_Non_Null_Base_Init_Proc (Typ) then
|
||||
-- No init proc for the type, so obviously no call to be found
|
||||
|
||||
return Empty;
|
||||
end if;
|
||||
|
||||
Init_Proc := Base_Init_Proc (Typ);
|
||||
|
||||
-- First scan the list containing the declaration of Var
|
||||
|
||||
Init_Call := Find_Init_Call_In_List (From => Next (Parent (Var)));
|
||||
|
||||
-- If not found, also look on Var's freeze actions list, if any, since
|
||||
-- the init call may have been moved there (case of an address clause
|
||||
-- applying to Var).
|
||||
|
||||
if No (Init_Call) and then Present (Freeze_Node (Var)) then
|
||||
Init_Call := Find_Init_Call_In_List
|
||||
(First (Actions (Freeze_Node (Var))));
|
||||
end if;
|
||||
|
||||
return Init_Call;
|
||||
end Find_Init_Call;
|
||||
|
||||
------------------------
|
||||
-- Find_Interface_ADT --
|
||||
------------------------
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2008, 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 --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
|
|
@ -343,6 +343,14 @@ package Exp_Util is
|
|||
-- declarations and/or allocations when the type is indefinite (including
|
||||
-- class-wide).
|
||||
|
||||
function Find_Init_Call
|
||||
(Var : Entity_Id;
|
||||
Rep_Clause : Node_Id) return Node_Id;
|
||||
-- Look for init_proc call for variable Var, either among declarations
|
||||
-- between that of Var and a subsequent Rep_Clause applying to Var, or
|
||||
-- in the list of freeze actions associated with Var, and if found, return
|
||||
-- that call node.
|
||||
|
||||
function Find_Interface_ADT
|
||||
(T : Entity_Id;
|
||||
Iface : Entity_Id) return Elmt_Id;
|
||||
|
|
|
|||
|
|
@ -536,10 +536,19 @@ package body Freeze is
|
|||
-- Otherwise, we require the address clause to be constant because
|
||||
-- the call to the initialization procedure (or the attach code) has
|
||||
-- to happen at the point of the declaration.
|
||||
-- Actually the IP call has been moved to the freeze actions
|
||||
-- anyway, so maybe we can relax this restriction???
|
||||
|
||||
else
|
||||
Check_Constant_Address_Clause (Expr, E);
|
||||
Set_Has_Delayed_Freeze (E, False);
|
||||
|
||||
-- Has_Delayed_Freeze was set on E when the address clause was
|
||||
-- analyzed. Reset the flag now unless freeze actions were
|
||||
-- attached to it in the mean time.
|
||||
|
||||
if No (Freeze_Node (E)) then
|
||||
Set_Has_Delayed_Freeze (E, False);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
if not Error_Posted (Expr)
|
||||
|
|
@ -2594,6 +2603,7 @@ package body Freeze is
|
|||
if Is_Array_Type (R_Type)
|
||||
and then not Is_Constrained (R_Type)
|
||||
and then not Is_Imported (E)
|
||||
and then VM_Target = No_VM
|
||||
and then Has_Foreign_Convention (E)
|
||||
and then Warn_On_Export_Import
|
||||
and then not Has_Warnings_Off (E)
|
||||
|
|
@ -5037,6 +5047,7 @@ package body Freeze is
|
|||
and then not Is_Constrained (Retype)
|
||||
and then Mechanism (E) not in Descriptor_Codes
|
||||
and then Warn_On_Export_Import
|
||||
and then VM_Target = No_VM
|
||||
then
|
||||
Error_Msg_N
|
||||
("?foreign convention function& should not return " &
|
||||
|
|
|
|||
|
|
@ -977,6 +977,21 @@ package body Sem_Ch13 is
|
|||
|
||||
Set_Has_Delayed_Freeze (U_Ent);
|
||||
|
||||
-- If an initialization call has been generated for this
|
||||
-- object, it needs to be deferred to after the freeze node
|
||||
-- we have just now added, otherwise GIGI will see a
|
||||
-- reference to the variable (as actual to the IP call)
|
||||
-- before its definition.
|
||||
|
||||
declare
|
||||
Init_Call : constant Node_Id := Find_Init_Call (U_Ent, N);
|
||||
begin
|
||||
if Present (Init_Call) then
|
||||
Remove (Init_Call);
|
||||
Append_Freeze_Action (U_Ent, Init_Call);
|
||||
end if;
|
||||
end;
|
||||
|
||||
if Is_Exported (U_Ent) then
|
||||
Error_Msg_N
|
||||
("& cannot be exported if an address clause is given",
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1997-2008, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1997-2009, 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- --
|
||||
|
|
@ -1460,18 +1460,18 @@ package body Sem_Elab is
|
|||
Process_Init_Proc : declare
|
||||
Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent);
|
||||
|
||||
function Find_Init_Call (Nod : Node_Id) return Traverse_Result;
|
||||
function Check_Init_Call (Nod : Node_Id) return Traverse_Result;
|
||||
-- Find subprogram calls within body of Init_Proc for Traverse
|
||||
-- instantiation below.
|
||||
|
||||
procedure Traverse_Body is new Traverse_Proc (Find_Init_Call);
|
||||
procedure Traverse_Body is new Traverse_Proc (Check_Init_Call);
|
||||
-- Traversal procedure to find all calls with body of Init_Proc
|
||||
|
||||
--------------------
|
||||
-- Find_Init_Call --
|
||||
--------------------
|
||||
---------------------
|
||||
-- Check_Init_Call --
|
||||
---------------------
|
||||
|
||||
function Find_Init_Call (Nod : Node_Id) return Traverse_Result is
|
||||
function Check_Init_Call (Nod : Node_Id) return Traverse_Result is
|
||||
Func : Entity_Id;
|
||||
|
||||
begin
|
||||
|
|
@ -1491,7 +1491,7 @@ package body Sem_Elab is
|
|||
else
|
||||
return OK;
|
||||
end if;
|
||||
end Find_Init_Call;
|
||||
end Check_Init_Call;
|
||||
|
||||
-- Start of processing for Process_Init_Proc
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue