OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[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
This commit is contained in:
Arnaud Charlet 2014-07-29 14:40:42 +02:00
parent 56386ab900
commit 0382062b3b
8 changed files with 270 additions and 179 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
gcc/ada/ChangeLog
View File

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

240
gcc/ada/exp_ch7.adb
View File

@ -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;
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.
begin
if Nkind (N) = N_Procedure_Call_Statement
and then Nkind (Name (N)) = N_Identifier
then
Call_Id := Entity (Name (N));
---------------------
-- Is_Init_Proc_Of --
---------------------
-- Obtain all possible initialization routines of the object
-- type and try to match the procedure call against one of
-- them.
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;
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;

18
gcc/ada/gnat_ugn.texi
View File

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

100
gcc/ada/sem_aux.adb
View File

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

25
gcc/ada/sem_aux.ads
View File

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

12
gcc/ada/sem_case.adb
View File

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

4
gcc/ada/sinfo.adb
View File

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

6
gcc/ada/sinfo.ads
View File

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