diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 19 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/exp_prag.adb | 29 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 68 | ||||
| -rw-r--r-- | gcc/ada/exp_util.ads | 10 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 15 | ||||
| -rw-r--r-- | gcc/ada/sem_elab.adb | 16 |
9 files changed, 145 insertions, 35 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 46a610ac01c..214bd7839fa 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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 diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 29eea5ecce5..bebdda082f2 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index c0cf131c565..e8030d9c196 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -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); diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 3cb421b4bd3..529fadebdb9 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -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; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 1fe6526c77d..be7c71a2551 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -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 -- ------------------------ diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 5848d5d7171..c310a211aa3 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -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; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 079b39cd0ec..406db6438bb 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -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 " & diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 89cfbb66cb6..11bb5ed998e 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -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", diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 34065991103..60a07322dc4 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -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 |
