diff options
author | Arnaud Charlet <charlet@gcc.gnu.org> | 2014-07-29 14:40:42 +0200 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2014-07-29 14:40:42 +0200 |
commit | 0382062b3b87859411e98bb2d3347020e7f45f48 (patch) | |
tree | a270d538296317d1c5acb6eda3c5aa21b378c4d1 | |
parent | 56386ab9004a24f057aff7aeaed15da1f025f7ff (diff) | |
download | gcc-0382062b3b87859411e98bb2d3347020e7f45f48.zip gcc-0382062b3b87859411e98bb2d3347020e7f45f48.tar.gz gcc-0382062b3b87859411e98bb2d3347020e7f45f48.tar.bz2 |
[multiple changes]
2014-07-29 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch7.adb (Build_BIP_Cleanup_Stmts): Remove
formal parameter Obj_Id and update the comment on usage. Renamed
Obj_Typ to Func_Typ and update all occurrences.
(Find_Last_Init): Remove formal parameter Decl and update the comment
on usage.
Remove local constants Obj_Id and Obj_Typ. Remove local variables
Init_Typ and Is_Conc. Remove the extraction of the initialization type.
(Find_Last_Init_In_Block): Remove formal parameter
Init_Typ and update the comment on usage.
(Is_Init_Call): Remove formal parameter Init_Typ and update the comment
on usage. Check whether the procedure call is an initialization
procedure of either the object type or the initialization type.
(Is_Init_Proc_Of): New routine.
(Process_Object_Declaration): Obj_Id and Obj_Typ are now global to this
routine. Add new variable Init_Typ. Add circuitry to extract the object
type as well as the initialization type.
2014-07-29 Robert Dewar <dewar@adacore.com>
* sem_case.adb: Minor reformatting.
* sem_aux.ads: Minor reformatting.
2014-07-29 Ed Schonberg <schonberg@adacore.com>
* sinfo.adb (Set_Else_Actions, Set_Then_Actions): Set parent
pointer on these fields, even though they are semantic, because
subsequent analysis and expansion of action nades may require
exploring the tree, for example to locate a node to be wrapped
when a function with controlled result is called.
2014-07-29 Claire Dross <dross@adacore.com>
* sem_aux.adb (Get_Binary_Nkind): Use case on
Name_Id instead of an intermediate string.
(Get_Unary_Nkind): Use case on Name_Id instead of an intermediate
string.
2014-07-29 Sergey Rybin <rybin@adacore.com frybin>
* gnat_ugn.texi (gnatelim, gnatstub, gnatmetric): Add note
about processing sources with preprocessor directives.
From-SVN: r213155
-rw-r--r-- | gcc/ada/ChangeLog | 44 | ||||
-rw-r--r-- | gcc/ada/exp_ch7.adb | 242 | ||||
-rw-r--r-- | gcc/ada/gnat_ugn.texi | 18 | ||||
-rw-r--r-- | gcc/ada/sem_aux.adb | 100 | ||||
-rw-r--r-- | gcc/ada/sem_aux.ads | 25 | ||||
-rw-r--r-- | gcc/ada/sem_case.adb | 12 | ||||
-rw-r--r-- | gcc/ada/sinfo.adb | 4 | ||||
-rw-r--r-- | gcc/ada/sinfo.ads | 6 |
8 files changed, 271 insertions, 180 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5ff2df1..7933eb7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,47 @@ +2014-07-29 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch7.adb (Build_BIP_Cleanup_Stmts): Remove + formal parameter Obj_Id and update the comment on usage. Renamed + Obj_Typ to Func_Typ and update all occurrences. + (Find_Last_Init): Remove formal parameter Decl and update the comment + on usage. + Remove local constants Obj_Id and Obj_Typ. Remove local variables + Init_Typ and Is_Conc. Remove the extraction of the initialization type. + (Find_Last_Init_In_Block): Remove formal parameter + Init_Typ and update the comment on usage. + (Is_Init_Call): Remove formal parameter Init_Typ and update the comment + on usage. Check whether the procedure call is an initialization + procedure of either the object type or the initialization type. + (Is_Init_Proc_Of): New routine. + (Process_Object_Declaration): Obj_Id and Obj_Typ are now global to this + routine. Add new variable Init_Typ. Add circuitry to extract the object + type as well as the initialization type. + +2014-07-29 Robert Dewar <dewar@adacore.com> + + * sem_case.adb: Minor reformatting. + * sem_aux.ads: Minor reformatting. + +2014-07-29 Ed Schonberg <schonberg@adacore.com> + + * sinfo.adb (Set_Else_Actions, Set_Then_Actions): Set parent + pointer on these fields, even though they are semantic, because + subsequent analysis and expansion of action nades may require + exploring the tree, for example to locate a node to be wrapped + when a function with controlled result is called. + +2014-07-29 Claire Dross <dross@adacore.com> + + * sem_aux.adb (Get_Binary_Nkind): Use case on + Name_Id instead of an intermediate string. + (Get_Unary_Nkind): Use case on Name_Id instead of an intermediate + string. + +2014-07-29 Sergey Rybin <rybin@adacore.com frybin> + + * gnat_ugn.texi (gnatelim, gnatstub, gnatmetric): Add note + about processing sources with preprocessor directives. + 2014-07-24 Martin Liska <mliska@suse.cz> * gcc-interface/trans.c (finalize_nrv): Adjust function call. diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 748279b..ad7a1d2 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -2066,13 +2066,20 @@ package body Exp_Ch7 is Has_No_Init : Boolean := False; Is_Protected : Boolean := False) is - Loc : constant Source_Ptr := Sloc (Decl); + Loc : constant Source_Ptr := Sloc (Decl); + Obj_Id : constant Entity_Id := Defining_Identifier (Decl); - function Build_BIP_Cleanup_Stmts - (Func_Id : Entity_Id; - Obj_Id : Entity_Id) return Node_Id; - -- Func_Id denotes a build-in-place function. Obj_Id is the return - -- object of Func_Id. Generate the following cleanup code: + Init_Typ : Entity_Id; + -- The initialization type of the related object declaration. Note + -- that this is not necessarely the same type as Obj_Typ because of + -- possible type derivations. + + Obj_Typ : Entity_Id; + -- The type of the related object declaration + + function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id; + -- Func_Id denotes a build-in-place function. Generate the following + -- cleanup code: -- -- if BIPallocfrom > Secondary_Stack'Pos -- and then BIPfinalizationmaster /= null @@ -2090,27 +2097,25 @@ package body Exp_Ch7 is -- allocation which Obj_Id renames. procedure Find_Last_Init - (Decl : Node_Id; - Last_Init : out Node_Id; + (Last_Init : out Node_Id; Body_Insert : out Node_Id); -- Find the last initialization call related to object declaration -- Decl. Last_Init denotes the last initialization call which follows - -- Decl. Body_Insert denotes the finalizer body could be potentially - -- inserted. + -- Decl. Body_Insert denotes a node where the finalizer body could be + -- potentially inserted after (if blocks are involved). ----------------------------- -- Build_BIP_Cleanup_Stmts -- ----------------------------- function Build_BIP_Cleanup_Stmts - (Func_Id : Entity_Id; - Obj_Id : Entity_Id) return Node_Id + (Func_Id : Entity_Id) return Node_Id is Decls : constant List_Id := New_List; Fin_Mas_Id : constant Entity_Id := Build_In_Place_Formal (Func_Id, BIP_Finalization_Master); - Obj_Typ : constant Entity_Id := Etype (Func_Id); + Func_Typ : constant Entity_Id := Etype (Func_Id); Temp_Id : constant Entity_Id := Entity (Prefix (Name (Parent (Obj_Id)))); @@ -2146,7 +2151,7 @@ package body Exp_Ch7 is -- caller's finalization master. -- Generate: - -- type Ptr_Typ is access Obj_Typ; + -- type Ptr_Typ is access Func_Typ; Ptr_Typ := Make_Temporary (Loc, 'P'); @@ -2155,7 +2160,7 @@ package body Exp_Ch7 is Defining_Identifier => Ptr_Typ, Type_Definition => Make_Access_To_Object_Definition (Loc, - Subtype_Indication => New_Occurrence_Of (Obj_Typ, Loc)))); + Subtype_Indication => New_Occurrence_Of (Func_Typ, Loc)))); -- Perform minor decoration in order to set the master and the -- storage pool attributes. @@ -2207,8 +2212,8 @@ package body Exp_Ch7 is -- and then BIPfinalizationmaster /= null -- then - if not Is_Constrained (Obj_Typ) - or else Is_Tagged_Type (Obj_Typ) + if not Is_Constrained (Func_Typ) + or else Is_Tagged_Type (Func_Typ) then declare Alloc : constant Entity_Id := @@ -2244,21 +2249,16 @@ package body Exp_Ch7 is -------------------- procedure Find_Last_Init - (Decl : Node_Id; - Last_Init : out Node_Id; + (Last_Init : out Node_Id; Body_Insert : out Node_Id) is - function Find_Last_Init_In_Block - (Blk : Node_Id; - Init_Typ : Entity_Id) return Node_Id; + function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id; -- Find the last initialization call within the statements of - -- block Blk. Init_Typ is type of the object being initialized. + -- block Blk. - function Is_Init_Call - (N : Node_Id; - Init_Typ : Entity_Id) return Boolean; + function Is_Init_Call (N : Node_Id) return Boolean; -- Determine whether node N denotes one of the initialization - -- procedures of type Init_Typ. + -- procedures of types Init_Typ or Obj_Typ. function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id; -- Given a statement which is part of a list, return the next @@ -2268,10 +2268,7 @@ package body Exp_Ch7 is -- Find_Last_Init_In_Block -- ----------------------------- - function Find_Last_Init_In_Block - (Blk : Node_Id; - Init_Typ : Entity_Id) return Node_Id - is + function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id is HSS : constant Node_Id := Handled_Statement_Sequence (Blk); Stmt : Node_Id; @@ -2286,9 +2283,9 @@ package body Exp_Ch7 is -- Peek inside nested blocks in case aborts are allowed if Nkind (Stmt) = N_Block_Statement then - return Find_Last_Init_In_Block (Stmt, Init_Typ); + return Find_Last_Init_In_Block (Stmt); - elsif Is_Init_Call (Stmt, Init_Typ) then + elsif Is_Init_Call (Stmt) then return Stmt; end if; @@ -2303,33 +2300,38 @@ package body Exp_Ch7 is -- Is_Init_Call -- ------------------ - function Is_Init_Call - (N : Node_Id; - Init_Typ : Entity_Id) return Boolean - is - Call_Id : Entity_Id; - Deep_Init : Entity_Id := Empty; - Prim_Init : Entity_Id := Empty; - Type_Init : Entity_Id := Empty; - - begin - if Nkind (N) = N_Procedure_Call_Statement - and then Nkind (Name (N)) = N_Identifier - then - Call_Id := Entity (Name (N)); + function Is_Init_Call (N : Node_Id) return Boolean is + function Is_Init_Proc_Of + (Subp_Id : Entity_Id; + Typ : Entity_Id) return Boolean; + -- Determine whether subprogram Subp_Id is a valid init proc of + -- type Typ. + + --------------------- + -- Is_Init_Proc_Of -- + --------------------- + + function Is_Init_Proc_Of + (Subp_Id : Entity_Id; + Typ : Entity_Id) return Boolean + is + Deep_Init : Entity_Id := Empty; + Prim_Init : Entity_Id := Empty; + Type_Init : Entity_Id := Empty; - -- Obtain all possible initialization routines of the object - -- type and try to match the procedure call against one of - -- them. + begin + -- Obtain all possible initialization routines of the + -- related type and try to match the subprogram entity + -- against one of them. -- Deep_Initialize - Deep_Init := TSS (Init_Typ, TSS_Deep_Initialize); + Deep_Init := TSS (Typ, TSS_Deep_Initialize); -- Primitive Initialize - if Is_Controlled (Init_Typ) then - Prim_Init := Find_Prim_Op (Init_Typ, Name_Initialize); + if Is_Controlled (Typ) then + Prim_Init := Find_Prim_Op (Typ, Name_Initialize); if Present (Prim_Init) then Prim_Init := Ultimate_Alias (Prim_Init); @@ -2338,16 +2340,37 @@ package body Exp_Ch7 is -- Type initialization routine - if Has_Non_Null_Base_Init_Proc (Init_Typ) then - Type_Init := Base_Init_Proc (Init_Typ); + if Has_Non_Null_Base_Init_Proc (Typ) then + Type_Init := Base_Init_Proc (Typ); end if; return - (Present (Deep_Init) and then Call_Id = Deep_Init) + (Present (Deep_Init) and then Subp_Id = Deep_Init) or else - (Present (Prim_Init) and then Call_Id = Prim_Init) + (Present (Prim_Init) and then Subp_Id = Prim_Init) or else - (Present (Type_Init) and then Call_Id = Type_Init); + (Present (Type_Init) and then Subp_Id = Type_Init); + end Is_Init_Proc_Of; + + -- Local variables + + Call_Id : Entity_Id; + + -- Start of processing for Is_Init_Call + + begin + if Nkind (N) = N_Procedure_Call_Statement + and then Nkind (Name (N)) = N_Identifier + then + Call_Id := Entity (Name (N)); + + -- Consider both the type of the object declaration and its + -- related initialization type. + + return + Is_Init_Proc_Of (Call_Id, Init_Typ) + or else + Is_Init_Proc_Of (Call_Id, Obj_Typ); end if; return False; @@ -2374,13 +2397,9 @@ package body Exp_Ch7 is -- Local variables - Obj_Id : constant Entity_Id := Defining_Entity (Decl); - Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id)); - Call : Node_Id; - Init_Typ : Entity_Id := Obj_Typ; - Is_Conc : Boolean := False; - Stmt : Node_Id; - Stmt_2 : Node_Id; + Call : Node_Id; + Stmt : Node_Id; + Stmt_2 : Node_Id; -- Start of processing for Find_Last_Init @@ -2395,34 +2414,6 @@ package body Exp_Ch7 is return; end if; - -- Obtain the proper type of the object being initialized - - loop - if Is_Concurrent_Type (Init_Typ) - and then Present (Corresponding_Record_Type (Init_Typ)) - then - Is_Conc := True; - Init_Typ := Corresponding_Record_Type (Init_Typ); - - elsif Is_Private_Type (Init_Typ) - and then Present (Full_View (Init_Typ)) - then - Init_Typ := Full_View (Init_Typ); - - elsif Is_Untagged_Derivation (Init_Typ) - and then not Is_Conc - then - Init_Typ := Root_Type (Init_Typ); - - else - exit; - end if; - end loop; - - if Init_Typ /= Base_Type (Init_Typ) then - Init_Typ := Base_Type (Init_Typ); - end if; - Stmt := Next_Suitable_Statement (Decl); -- A limited controlled object initialized by a function call uses @@ -2442,7 +2433,7 @@ package body Exp_Ch7 is -- In this scenario the declaration of the temporary acts as the -- last initialization statement. - if Is_Limited_Type (Init_Typ) + if Is_Limited_Type (Obj_Typ) and then Has_Init_Expression (Decl) and then No (Expression (Decl)) then @@ -2482,7 +2473,7 @@ package body Exp_Ch7 is -- within a block. elsif Nkind (Stmt) = N_Block_Statement then - Last_Init := Find_Last_Init_In_Block (Stmt, Init_Typ); + Last_Init := Find_Last_Init_In_Block (Stmt); Body_Insert := Stmt; -- Otherwise the initialization calls follow the related object @@ -2496,14 +2487,14 @@ package body Exp_Ch7 is if Present (Stmt_2) then if Nkind (Stmt_2) = N_Block_Statement then - Call := Find_Last_Init_In_Block (Stmt_2, Init_Typ); + Call := Find_Last_Init_In_Block (Stmt_2); if Present (Call) then Last_Init := Call; Body_Insert := Stmt_2; end if; - elsif Is_Init_Call (Stmt_2, Init_Typ) then + elsif Is_Init_Call (Stmt_2) then Last_Init := Stmt_2; Body_Insert := Last_Init; end if; @@ -2511,7 +2502,7 @@ package body Exp_Ch7 is -- If the object lacks a call to Deep_Initialize, then it must -- have a call to its related type init proc. - elsif Is_Init_Call (Stmt, Init_Typ) then + elsif Is_Init_Call (Stmt) then Last_Init := Stmt; Body_Insert := Last_Init; end if; @@ -2520,7 +2511,6 @@ package body Exp_Ch7 is -- Local variables - Obj_Id : constant Entity_Id := Defining_Identifier (Decl); Body_Ins : Node_Id; Count_Ins : Node_Id; Fin_Call : Node_Id; @@ -2529,23 +2519,60 @@ package body Exp_Ch7 is Label : Node_Id; Label_Id : Entity_Id; Obj_Ref : Node_Id; - Obj_Typ : Entity_Id; -- Start of processing for Process_Object_Declaration begin + -- Handle the object type and the reference to the object + Obj_Ref := New_Occurrence_Of (Obj_Id, Loc); Obj_Typ := Base_Type (Etype (Obj_Id)); - -- Handle access types + loop + if Is_Access_Type (Obj_Typ) then + Obj_Typ := Directly_Designated_Type (Obj_Typ); + Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); - if Is_Access_Type (Obj_Typ) then - Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); - Obj_Typ := Directly_Designated_Type (Obj_Typ); - end if; + elsif Is_Concurrent_Type (Obj_Typ) + and then Present (Corresponding_Record_Type (Obj_Typ)) + then + Obj_Typ := Corresponding_Record_Type (Obj_Typ); + Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref); + + elsif Is_Private_Type (Obj_Typ) + and then Present (Full_View (Obj_Typ)) + then + Obj_Typ := Full_View (Obj_Typ); + Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref); + + elsif Obj_Typ /= Base_Type (Obj_Typ) then + Obj_Typ := Base_Type (Obj_Typ); + Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref); + + else + exit; + end if; + end loop; Set_Etype (Obj_Ref, Obj_Typ); + -- Handle the initialization type of the object declaration + + Init_Typ := Obj_Typ; + loop + if Is_Private_Type (Init_Typ) + and then Present (Full_View (Init_Typ)) + then + Init_Typ := Full_View (Init_Typ); + + elsif Is_Untagged_Derivation (Init_Typ) then + Init_Typ := Root_Type (Init_Typ); + + else + exit; + end if; + end loop; + -- Set a new value for the state counter and insert the statement -- after the object declaration. Generate: @@ -2571,7 +2598,7 @@ package body Exp_Ch7 is -- either [Deep_]Initialize or the type specific init proc. else - Find_Last_Init (Decl, Count_Ins, Body_Ins); + Find_Last_Init (Count_Ins, Body_Ins); end if; Insert_After (Count_Ins, Inc_Decl); @@ -2754,8 +2781,7 @@ package body Exp_Ch7 is if Is_Build_In_Place_Function (Func_Id) and then Needs_BIP_Finalization_Master (Func_Id) then - Append_To - (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id, Obj_Id)); + Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id)); end if; end; end if; diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 04633a2..062659e 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -11418,6 +11418,12 @@ After a full successful build of the main subprogram @code{gnatelim} can be called without specifying sources to analyse, in this case it computes the source closure of the main unit from the @file{ALI} files. +If the set of sources to be processed by @code{gnatelim} contains sources with +preprocessing directives +then the needed options should be provided to run preprocessor as a part of +the @command{gnatelim} call, and the generated set of pragmas @code{Eliminate} +will correspond to preprocessed sources. + The following command will create the set of @file{ALI} files needed for @code{gnatelim}: @@ -15637,6 +15643,13 @@ Project Files}). Another possibility is to specify the source search path and needed configuration files in @option{-cargs} section of @command{gnatmetric} call, see the description of the @command{gnatmetric} switches below. +If the set of sources to be processed by @code{gnatmetric} contains sources with +preprocessing directives +then the needed options should be provided to run preprocessor as a part of +the @command{gnatmetric} call, and the computed metrics +will correspond to preprocessed sources. + + The @command{gnatmetric} command has the form @smallexample @@ -19373,6 +19386,11 @@ Project Files}). Another possibility is to specify the source search path and needed configuration files in @option{-cargs} section of @command{gnatstub} call, see the description of the @command{gnatstub} switches below. +If the @command{gnatstub} argument source contains preprocessing directives +then the needed options should be provided to run preprocessor as a part of +the @command{gnatstub} call, and the generated body stub will correspond to +the preprocessed source. + By default, all the program unit body stubs generated by @code{gnatstub} raise the predefined @code{Program_Error} exception, which will catch accidental calls of generated stubs. This behavior can be changed with diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 0344637..4b251e3 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -439,45 +439,45 @@ package body Sem_Aux is --------------------- function Get_Binary_Nkind (Op : Entity_Id) return Node_Kind is - Name : constant String := Get_Name_String (Chars (Op)); begin - if Name = "Oadd" then - return N_Op_Add; - elsif Name = "Oconcat" then - return N_Op_Concat; - elsif Name = "Oexpon" then - return N_Op_Expon; - elsif Name = "Osubtract" then - return N_Op_Subtract; - elsif Name = "Omod" then - return N_Op_Mod; - elsif Name = "Omultiply" then - return N_Op_Multiply; - elsif Name = "Odivide" then - return N_Op_Divide; - elsif Name = "Orem" then - return N_Op_Rem; - elsif Name = "Oand" then - return N_Op_And; - elsif Name = "Oeq" then - return N_Op_Eq; - elsif Name = "Oge" then - return N_Op_Ge; - elsif Name = "Ogt" then - return N_Op_Gt; - elsif Name = "Ole" then - return N_Op_Le; - elsif Name = "Olt" then - return N_Op_Lt; - elsif Name = "One" then - return N_Op_Ne; - elsif Name = "Oxor" then - return N_Op_Or; - elsif Name = "Oor" then - return N_Op_Xor; - else - raise Program_Error; - end if; + case Chars (Op) is + when Name_Op_Add => + return N_Op_Add; + when Name_Op_Concat => + return N_Op_Concat; + when Name_Op_Expon => + return N_Op_Expon; + when Name_Op_Subtract => + return N_Op_Subtract; + when Name_Op_Mod => + return N_Op_Mod; + when Name_Op_Multiply => + return N_Op_Multiply; + when Name_Op_Divide => + return N_Op_Divide; + when Name_Op_Rem => + return N_Op_Rem; + when Name_Op_And => + return N_Op_And; + when Name_Op_Eq => + return N_Op_Eq; + when Name_Op_Ge => + return N_Op_Ge; + when Name_Op_Gt => + return N_Op_Gt; + when Name_Op_Le => + return N_Op_Le; + when Name_Op_Lt => + return N_Op_Lt; + when Name_Op_Ne => + return N_Op_Ne; + when Name_Op_Or => + return N_Op_Or; + when Name_Op_Xor => + return N_Op_Xor; + when others => + raise Program_Error; + end case; end Get_Binary_Nkind; ------------------ @@ -652,19 +652,19 @@ package body Sem_Aux is --------------------- function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind is - Name : constant String := Get_Name_String (Chars (Op)); begin - if Name = "Oabs" then - return N_Op_Abs; - elsif Name = "Osubtract" then - return N_Op_Minus; - elsif Name = "Onot" then - return N_Op_Not; - elsif Name = "Oadd" then - return N_Op_Plus; - else - raise Program_Error; - end if; + case Chars (Op) is + when Name_Op_Abs => + return N_Op_Abs; + when Name_Op_Subtract => + return N_Op_Minus; + when Name_Op_Not => + return N_Op_Not; + when Name_Op_Add => + return N_Op_Plus; + when others => + raise Program_Error; + end case; end Get_Unary_Nkind; --------------------------------- diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index 4eaf1bf..c40ddab 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -152,6 +152,18 @@ package Sem_Aux is -- Typ must be a tagged record type. This function returns the Entity for -- the first _Tag field in the record type. + function Get_Binary_Nkind (Op : Entity_Id) return Node_Kind; + -- Op must be an entity with an Ekind of E_Operator. This function returns + -- the Nkind value that would be used to construct a binary operator node + -- referencing this entity. It is an error to call this function if Ekind + -- (Op) /= E_Operator. + + function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind; + -- Op must be an entity with an Ekind of E_Operator. This function returns + -- the Nkind value that would be used to construct a unary operator node + -- referencing this entity. It is an error to call this function if Ekind + -- (Op) /= E_Operator. + function Get_Rep_Item (E : Entity_Id; Nam : Name_Id; @@ -386,17 +398,4 @@ package Sem_Aux is -- package specification. Simplifies handling of child units, and better -- than the old idiom: Specification (Unit_Declaration_Node (Pack_Id)). - function Get_Binary_Nkind (Op : Entity_Id) return Node_Kind; - -- Op must be an entity with an Ekind of E_Operator. - -- This function returns the Nkind value that would - -- be used to construct a binary operator node referencing - -- this entity. It is an error to call this function - -- if Ekind (Op) /= E_Operator. - - function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind; - -- Op must be an entity with an Ekind of E_Operator. - -- This function returns the Nkind value that would - -- be used to construct a unary operator node referencing - -- this entity. It is an error to call this function - -- if Ekind (Op) /= E_Operator. end Sem_Aux; diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index fc7dc44..7a8a60a 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -647,7 +647,7 @@ package body Sem_Case is Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type); Num_Choices : constant Nat := Choice_Table'Last; Has_Predicate : constant Boolean := - Is_Static_Subtype (Bounds_Type) + Is_OK_Static_Subtype (Bounds_Type) and then Present (Static_Predicate (Bounds_Type)); Choice : Node_Id; @@ -977,7 +977,7 @@ package body Sem_Case is -- Special case: only an others case is present. The others case -- covers the full range of the type. - if Is_Static_Subtype (Choice_Type) then + if Is_OK_Static_Subtype (Choice_Type) then Choice := New_Occurrence_Of (Choice_Type, Loc); else Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc); @@ -1268,9 +1268,9 @@ package body Sem_Case is -- Do not insert non static choices in the table to be sorted - elsif not Is_Static_Expression (Lo) + elsif not Is_OK_Static_Expression (Lo) or else - not Is_Static_Expression (Hi) + not Is_OK_Static_Expression (Hi) then Process_Non_Static_Choice (Choice); return; @@ -1498,7 +1498,7 @@ package body Sem_Case is -- Not predicated subtype case - elsif not Is_Static_Subtype (E) then + elsif not Is_OK_Static_Subtype (E) then Process_Non_Static_Choice (Choice); else Check @@ -1522,7 +1522,7 @@ package body Sem_Case is begin E := Entity (Subtype_Mark (Choice)); - if not Is_Static_Subtype (E) then + if not Is_OK_Static_Subtype (E) then Process_Non_Static_Choice (Choice); else diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index ec7a23f..2d21669 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -4238,7 +4238,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_If_Expression); - Set_List3 (N, Val); -- semantic field, no parent set + Set_List3_With_Parent (N, Val); -- semantic field, but needs parents end Set_Else_Actions; procedure Set_Else_Statements @@ -6266,7 +6266,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_If_Expression); - Set_List2 (N, Val); -- semantic field, no parent set + Set_List2_With_Parent (N, Val); -- semantic field, but needs parents end Set_Then_Actions; procedure Set_Then_Statements diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 86d95305..36bd33f 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -4262,7 +4262,11 @@ package Sinfo is -- Note: the Then_Actions and Else_Actions fields are always set to -- No_List in the tree passed to Gigi. These fields are used only - -- for temporary processing purposes in the expander. + -- for temporary processing purposes in the expander. Even though they + -- are semantic fields, their parent pointers are set because analysis + -- of actions nodes in those lists may generate additional actions that + -- need to know their insertion point (for example for the creation of + -- transient scopes). ---------------------------- -- 4.5.7 Case Expression -- |