procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[multiple changes]

Browse source 
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 2009-06-21 15:19:57 +02:00
parent 4f91a2557f
commit f3b57ab079
9 changed files with 145 additions and 35 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
gcc/ada/ChangeLog
View file

@ -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

2
gcc/ada/einfo.ads
View file

@ -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.

8
gcc/ada/exp_ch3.adb
View file

@ -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);

29
gcc/ada/exp_prag.adb
View file

@ -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;

68
gcc/ada/exp_util.adb
View file

@ -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 --
------------------------

10
gcc/ada/exp_util.ads
View file

@ -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;

13
gcc/ada/freeze.adb
View file

@ -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 " &

15
gcc/ada/sem_ch13.adb
View file

@ -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",

16
gcc/ada/sem_elab.adb
View file

@ -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