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

[multiple changes]

Browse source 
2012-10-29  Robert Dewar  <dewar@adacore.com>

	* sem_ch5.adb (Analyze_Loop_Statement): Add warning for identical
	inner/outer ranges.

2012-10-29  Robert Dewar  <dewar@adacore.com>

	* einfo.ads: Change terminology "present" to "defined" in talking
	about whether a given field is defined for a given entity kind.

2012-10-29  Bob Duff  <duff@adacore.com>

	* atree.ads: Minor comment fix.

2012-10-29  Bob Duff  <duff@adacore.com>

	* sem_ch13.adb (Replace_Type_Reference): Set_Comes_From_Source.
	Otherwise, the node is ignored by ASIS.
	* sem_ch5.adb: Minor reformatting.

2012-10-29  Thomas Quinot  <quinot@adacore.com>

	* exp_attr.adb, exp_dist.adb, exp_dist.ads (Build_To_Any_Call): Pass
	an explicit Loc parameter to set the source location of generated
	nodes.

2012-10-29  Tristan Gingold  <gingold@adacore.com>

	* exp_ch9.adb (Build_Task_Activation_Call): Do nothing on
	restricted profile.
	* bindgen.adb (System_Tasking_Restricted_Stages_Used): New variable.
	(Gen_Adainit): Declare and call Activate_Tasks when the above variable
	is set.
	(Resolve_Binder_Options): Set the variable.
	* rtsfind.ads (RE_Activate_Restricted_Tasks): Removed (now unused).
	* s-tarest.adb (Tasks_Activation_Chain): New variable.
	(Activate_Restricted_Tasks): Removed, and replaced by ...
	(Activate_Tasks): New procedure, to activate all tasks at
	the end of elaboration.
	(Create_Restricted_Tasks): Chain parameter is now unreferenced.	Put
	the created task on the Tasks_Activation_Chain list.
	* s-tarest.ads (Activate_Restricted_Tasks): Removed.
	(Activate_Tasks): Added.

2012-10-29  Gary Dismukes  <dismukes@adacore.com>

	* sem_res.adb (Resolve_If_Expression): Compare subtype of the 'then'
	expression against the subtype of the expression rather than comparing
	base types, same as is already done for the 'else' expression.

From-SVN: r192918
This commit is contained in:
Arnaud Charlet 2012-10-29 11:07:33 +01:00
parent 2a8fcd43bd
commit 30ebb1146d
14 changed files with 648 additions and 507 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

50
gcc/ada/ChangeLog
View file

@ -1,3 +1,53 @@
2012-10-29 Robert Dewar <dewar@adacore.com>
* sem_ch5.adb (Analyze_Loop_Statement): Add warning for identical
inner/outer ranges.
2012-10-29 Robert Dewar <dewar@adacore.com>
* einfo.ads: Change terminology "present" to "defined" in talking
about whether a given field is defined for a given entity kind.
2012-10-29 Bob Duff <duff@adacore.com>
* atree.ads: Minor comment fix.
2012-10-29 Bob Duff <duff@adacore.com>
* sem_ch13.adb (Replace_Type_Reference): Set_Comes_From_Source.
Otherwise, the node is ignored by ASIS.
* sem_ch5.adb: Minor reformatting.
2012-10-29 Thomas Quinot <quinot@adacore.com>
* exp_attr.adb, exp_dist.adb, exp_dist.ads (Build_To_Any_Call): Pass
an explicit Loc parameter to set the source location of generated
nodes.
2012-10-29 Tristan Gingold <gingold@adacore.com>
* exp_ch9.adb (Build_Task_Activation_Call): Do nothing on
restricted profile.
* bindgen.adb (System_Tasking_Restricted_Stages_Used): New variable.
(Gen_Adainit): Declare and call Activate_Tasks when the above variable
is set.
(Resolve_Binder_Options): Set the variable.
* rtsfind.ads (RE_Activate_Restricted_Tasks): Removed (now unused).
* s-tarest.adb (Tasks_Activation_Chain): New variable.
(Activate_Restricted_Tasks): Removed, and replaced by ...
(Activate_Tasks): New procedure, to activate all tasks at
the end of elaboration.
(Create_Restricted_Tasks): Chain parameter is now unreferenced. Put
the created task on the Tasks_Activation_Chain list.
* s-tarest.ads (Activate_Restricted_Tasks): Removed.
(Activate_Tasks): Added.
2012-10-29 Gary Dismukes <dismukes@adacore.com>
* sem_res.adb (Resolve_If_Expression): Compare subtype of the 'then'
expression against the subtype of the expression rather than comparing
base types, same as is already done for the 'else' expression.
2012-10-29 Steve Baird <baird@adacore.com>
* sem_ch13.adb (Analyze_Attribute_Definition_Clause): If CodePeer_Mode

2
gcc/ada/atree.ads
View file

@ -767,7 +767,7 @@ package Atree is
-- Note that this routine is very rarely used, since usually the
-- default mechanism provided sets the right value, but in some
-- unusual cases, the value needs to be reset (e.g. when a source
-- node is copied, and the copy must not have Comes_From_Source set.
-- node is copied, and the copy must not have Comes_From_Source set).
procedure Set_Has_Aspects (N : Node_Id; Val : Boolean := True);
pragma Inline (Set_Has_Aspects);

30
gcc/ada/bindgen.adb
View file

@ -78,6 +78,12 @@ package body Bindgen is
-- disallow the creation of new dispatching domains just before calling
-- the main procedure from the environment task.
System_Tasking_Restricted_Stages_Used : Boolean := False;
-- Flag indicating whether the unit System.Tasking.Restricted.Stages is in
-- the closure of the partition. This is set by Resolve_Binder_Options,
-- and it used to call a routine to active all the tasks at the end of
-- the elaboration.
Lib_Final_Built : Boolean := False;
-- Flag indicating whether the finalize_library rountine has been built
@ -534,6 +540,12 @@ package body Bindgen is
WBI ("");
end if;
if System_Tasking_Restricted_Stages_Used then
WBI (" procedure Activate_Tasks;");
WBI (" pragma Import (C, Activate_Tasks," &
" ""__gnat_activate_tasks"");");
end if;
WBI (" begin");
if Main_Priority /= No_Main_Priority then
@ -625,6 +637,14 @@ package body Bindgen is
WBI (" pragma Import (C, Handler_Installed, " &
"""__gnat_handler_installed"");");
-- Import task activation procedure for ravenscar
if System_Tasking_Restricted_Stages_Used then
WBI (" procedure Activate_Tasks;");
WBI (" pragma Import (C, Activate_Tasks," &
" ""__gnat_activate_tasks"");");
end if;
-- The import of the soft link which performs library-level object
-- finalization is not needed for VM targets; regular Ada is used in
-- that case. For restricted run-time libraries (ZFP and Ravenscar)
@ -945,6 +965,10 @@ package body Bindgen is
WBI (" Freeze_Dispatching_Domains;");
end if;
if System_Tasking_Restricted_Stages_Used then
WBI (" Activate_Tasks;");
end if;
-- Case of main program is CIL function or procedure
if VM_Target = CLI_Target
@ -2863,6 +2887,12 @@ package body Bindgen is
if OpenVMS_On_Target and then Name_Buffer (1 .. 5) = "dec%s" then
With_DECGNAT := True;
end if;
-- Likewise for the use of restricted tasking
if Name_Buffer (1 .. 34) = "system.tasking.restricted.stages%s" then
System_Tasking_Restricted_Stages_Used := True;
end if;
end loop;
end Resolve_Binder_Options;

861
gcc/ada/einfo.ads
View file

File diff suppressed because it is too large Load diff

3
gcc/ada/exp_attr.adb
View file

@ -5141,7 +5141,8 @@ package body Exp_Attr is
begin
Rewrite (N,
Build_To_Any_Call
(Convert_To (P_Type,
(Loc,
Convert_To (P_Type,
Relocate_Node (First (Exprs))), Decls));
Insert_Actions (N, Decls);
Analyze_And_Resolve (N, RTE (RE_Any));

13
gcc/ada/exp_ch9.adb
View file

@ -4817,6 +4817,13 @@ package body Exp_Ch9 is
P : Node_Id;
begin
-- On restricted profile, all the tasks will be activated at the end
-- of the elaboration (Sequential elaboration policy).
if Restricted_Profile then
return;
end if;
-- Get the activation chain entity. Except in the case of a package
-- body, this is in the node that was passed. For a package body, we
-- have to find the corresponding package declaration node.
@ -4835,11 +4842,7 @@ package body Exp_Ch9 is
end if;
if Present (Chain) then
if Restricted_Profile then
Name := New_Reference_To (RTE (RE_Activate_Restricted_Tasks), Loc);
else
Name := New_Reference_To (RTE (RE_Activate_Tasks), Loc);
end if;
Name := New_Reference_To (RTE (RE_Activate_Tasks), Loc);
Call :=
Make_Procedure_Call_Statement (Loc,

63
gcc/ada/exp_dist.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, 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- --
@ -803,12 +803,14 @@ package body Exp_Dist is
-- the declaration and entity for the newly-created function.
function Build_To_Any_Call
(N : Node_Id;
(Loc : Source_Ptr;
N : Node_Id;
Decls : List_Id) return Node_Id;
-- Build call to To_Any attribute function with expression as actual
-- parameter. Decls is the declarations list for an appropriate
-- enclosing scope of the point where the call will be inserted; if
-- the To_Any attribute for Typ needs to be generated at this point,
-- parameter. Loc is the reference location ofr generated nodes,
-- Decls is the declarations list for an appropriate enclosing scope
-- of the point where the call will be inserted; if the To_Any
-- attribute for the type of N needs to be generated at this point,
-- its declaration is appended to Decls.
procedure Build_To_Any_Function
@ -879,7 +881,8 @@ package body Exp_Dist is
renames PolyORB_Support.Helpers.Build_From_Any_Call;
function Build_To_Any_Call
(N : Node_Id;
(Loc : Source_Ptr;
N : Node_Id;
Decls : List_Id) return Node_Id
renames PolyORB_Support.Helpers.Build_To_Any_Call;
@ -6562,7 +6565,7 @@ package body Exp_Dist is
Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc),
Expression =>
PolyORB_Support.Helpers.Build_To_Any_Call
(RACW_Parameter, No_List)));
(Loc, RACW_Parameter, No_List)));
Statements := New_List (
Make_Procedure_Call_Statement (Loc,
@ -7362,7 +7365,7 @@ package body Exp_Dist is
-- the first one.
Expr := PolyORB_Support.Helpers.Build_To_Any_Call
(Actual_Parameter, Decls);
(Loc, Actual_Parameter, Decls);
else
Expr := Make_Function_Call (Loc,
@ -7448,7 +7451,7 @@ package body Exp_Dist is
New_Occurrence_Of (RTE (RE_Any), Loc),
Expression =>
PolyORB_Support.Helpers.Build_To_Any_Call
(Parameter_Exp, Decls)));
(Loc, Parameter_Exp, Decls)));
Append_To (Extra_Formal_Statements,
Add_Parameter_To_NVList (Loc,
@ -7934,7 +7937,7 @@ package body Exp_Dist is
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc),
PolyORB_Support.Helpers.Build_To_Any_Call
(New_Occurrence_Of (Object, Loc), Decls))));
(Loc, New_Occurrence_Of (Object, Loc), Decls))));
end if;
-- For RACW controlling formals, the Etyp of Object is always
@ -8094,7 +8097,7 @@ package body Exp_Dist is
Parameter_Associations => New_List (
New_Occurrence_Of (Request_Parameter, Loc),
PolyORB_Support.Helpers.Build_To_Any_Call
(New_Occurrence_Of (Result, Loc), Decls))));
(Loc, New_Occurrence_Of (Result, Loc), Decls))));
-- A DSA function does not have out or inout arguments
end;
@ -9219,11 +9222,10 @@ package body Exp_Dist is
-----------------------
function Build_To_Any_Call
(N : Node_Id;
(Loc : Source_Ptr;
N : Node_Id;
Decls : List_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Typ : Entity_Id := Etype (N);
U_Type : Entity_Id;
C_Type : Entity_Id;
@ -9463,7 +9465,8 @@ package body Exp_Dist is
(Rt_Type,
New_Occurrence_Of (Expr_Parameter, Loc));
begin
Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls));
Set_Expression (Any_Decl,
Build_To_Any_Call (Loc, Expr, Decls));
end;
elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
@ -9479,7 +9482,7 @@ package body Exp_Dist is
begin
Set_Expression
(Any_Decl, Build_To_Any_Call (Expr, Decls));
(Any_Decl, Build_To_Any_Call (Loc, Expr, Decls));
end;
-- Comment needed here (and label on declare block ???)
@ -9535,7 +9538,7 @@ package body Exp_Dist is
RTE (RE_Add_Aggregate_Element), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Container, Loc),
Build_To_Any_Call (Field_Ref, Decls))));
Build_To_Any_Call (Loc, Field_Ref, Decls))));
else
-- A variant part
@ -9660,7 +9663,8 @@ package body Exp_Dist is
Parameter_Associations => New_List (
New_Occurrence_Of (Union_Any, Loc),
Build_To_Any_Call
(Make_Discriminant_Reference,
(Loc,
Make_Discriminant_Reference,
Block_Decls))));
-- Populate inner struct aggregate
@ -9761,7 +9765,8 @@ package body Exp_Dist is
Choices => New_List (
Make_Integer_Literal (Loc, Counter)),
Expression =>
Build_To_Any_Call (Discriminant, Decls)));
Build_To_Any_Call (Loc,
Discriminant, Decls)));
end;
Counter := Counter + 1;
@ -9850,7 +9855,7 @@ package body Exp_Dist is
if Etype (Datum) = RTE (RE_Any) then
Element_Any := Datum;
else
Element_Any := Build_To_Any_Call (Datum, Decls);
Element_Any := Build_To_Any_Call (Loc, Datum, Decls);
end if;
Append_To (Stmts,
@ -9889,7 +9894,7 @@ package body Exp_Dist is
RTE (RE_Add_Aggregate_Element), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc),
Build_To_Any_Call (
Build_To_Any_Call (Loc,
OK_Convert_To (Etype (Index),
Make_Attribute_Reference (Loc,
Prefix =>
@ -9910,7 +9915,7 @@ package body Exp_Dist is
-- Integer types
Set_Expression (Any_Decl,
Build_To_Any_Call (
Build_To_Any_Call (Loc,
OK_Convert_To (
Find_Numeric_Representation (Typ),
New_Occurrence_Of (Expr_Parameter, Loc)),
@ -10454,7 +10459,7 @@ package body Exp_Dist is
Set_Etype (Expr, Disc_Type);
Append_To (Union_TC_Params,
Build_To_Any_Call (Expr, Decls));
Build_To_Any_Call (Loc, Expr, Decls));
Add_Params_For_Variant_Components;
J := J + Uint_1;
@ -10495,7 +10500,7 @@ package body Exp_Dist is
begin
Set_Etype (Exp, Disc_Type);
Append_To (Union_TC_Params,
Build_To_Any_Call (Exp, Decls));
Build_To_Any_Call (Loc, Exp, Decls));
end;
Add_Params_For_Variant_Components;
@ -10509,7 +10514,7 @@ package body Exp_Dist is
New_Copy_Tree (Choice);
begin
Append_To (Union_TC_Params,
Build_To_Any_Call (Exp, Decls));
Build_To_Any_Call (Loc, Exp, Decls));
end;
Add_Params_For_Variant_Components;
@ -10679,7 +10684,7 @@ package body Exp_Dist is
if Constrained then
Inner_TypeCode := Make_Constructed_TypeCode
(RTE (RE_TC_Array), New_List (
Build_To_Any_Call (
Build_To_Any_Call (Loc,
OK_Convert_To (RTE (RE_Unsigned_32),
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc),
@ -10688,7 +10693,7 @@ package body Exp_Dist is
Make_Integer_Literal (Loc,
Intval => Ndim - J + 1)))),
Decls),
Build_To_Any_Call (Inner_TypeCode, Decls)));
Build_To_Any_Call (Loc, Inner_TypeCode, Decls)));
else
-- Unconstrained case: add low bound for each
@ -10705,11 +10710,11 @@ package body Exp_Dist is
Inner_TypeCode := Make_Constructed_TypeCode
(RTE (RE_TC_Sequence), New_List (
Build_To_Any_Call (
Build_To_Any_Call (Loc,
OK_Convert_To (RTE (RE_Unsigned_32),
Make_Integer_Literal (Loc, 0)),
Decls),
Build_To_Any_Call (Inner_TypeCode, Decls)));
Build_To_Any_Call (Loc, Inner_TypeCode, Decls)));
end if;
end loop;

13
gcc/ada/exp_dist.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, 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- --
@ -144,13 +144,14 @@ package Exp_Dist is
-- declaration is appended to Decls.
function Build_To_Any_Call
(N : Node_Id;
(Loc : Source_Ptr;
N : Node_Id;
Decls : List_Id) return Node_Id;
-- Build call to To_Any attribute function with expression as actual
-- parameter. Decls is the declarations list for an appropriate
-- enclosing scope of the point where the call will be inserted; if
-- the To_Any attribute for Typ needs to be generated at this point,
-- its declaration is appended to Decls.
-- parameter. Loc is the reference location for generated nodes, Decls is
-- the declarations list for an appropriate enclosing scope of the point
-- where the call will be inserted; if the To_Any attribute for Typ needs
-- to be generated at this point, its declaration is appended to Decls.
function Build_TypeCode_Call
(Loc : Source_Ptr;

2
gcc/ada/rtsfind.ads
View file

@ -1756,7 +1756,6 @@ package Rtsfind is
RE_Timed_Task_Entry_Call, -- System.Tasking.Rendezvous
RE_Timed_Selective_Wait, -- System.Tasking.Rendezvous
RE_Activate_Restricted_Tasks, -- System.Tasking.Restricted.Stages
RE_Complete_Restricted_Activation, -- System.Tasking.Restricted.Stages
RE_Create_Restricted_Task, -- System.Tasking.Restricted.Stages
RE_Complete_Restricted_Task, -- System.Tasking.Restricted.Stages
@ -3042,7 +3041,6 @@ package Rtsfind is
RE_Timed_Task_Entry_Call => System_Tasking_Rendezvous,
RE_Timed_Selective_Wait => System_Tasking_Rendezvous,
RE_Activate_Restricted_Tasks => System_Tasking_Restricted_Stages,
RE_Complete_Restricted_Activation => System_Tasking_Restricted_Stages,
RE_Create_Restricted_Task => System_Tasking_Restricted_Stages,
RE_Complete_Restricted_Task => System_Tasking_Restricted_Stages,

26
gcc/ada/s-tarest.adb
View file

@ -70,6 +70,9 @@ package body System.Tasking.Restricted.Stages is
use Task_Primitives.Operations;
use Task_Info;
Tasks_Activation_Chain : Task_Id;
-- Chain of all the tasks to activate
Global_Task_Lock : aliased System.Task_Primitives.RTS_Lock;
-- This is a global lock; it is used to execute in mutual exclusion
-- from all other tasks. It is only used by Task_Lock and Task_Unlock.
@ -298,9 +301,9 @@ package body System.Tasking.Restricted.Stages is
-- Restricted GNARLI --
-----------------------
-------------------------------
-- Activate_Restricted_Tasks --
-------------------------------
--------------------
-- Activate_Tasks --
--------------------
-- Note that locks of activator and activated task are both locked here.
-- This is necessary because C.State and Self.Wait_Count have to be
@ -308,9 +311,7 @@ package body System.Tasking.Restricted.Stages is
-- created before the activated task. That satisfies our
-- in-order-of-creation ATCB locking policy.
procedure Activate_Restricted_Tasks
(Chain_Access : Activation_Chain_Access)
is
procedure Activate_Tasks is
Self_ID : constant Task_Id := STPO.Self;
C : Task_Id;
Activate_Prio : System.Any_Priority;
@ -332,8 +333,7 @@ package body System.Tasking.Restricted.Stages is
-- Activate all the tasks in the chain. Creation of the thread of
-- control was deferred until activation. So create it now.
C := Chain_Access.T_ID;
C := Tasks_Activation_Chain;
while C /= null loop
if C.Common.State /= Terminated then
pragma Assert (C.Common.State = Unactivated);
@ -384,8 +384,8 @@ package body System.Tasking.Restricted.Stages is
-- Remove the tasks from the chain
Chain_Access.T_ID := null;
end Activate_Restricted_Tasks;
Tasks_Activation_Chain := null;
end Activate_Tasks;
------------------------------------
-- Complete_Restricted_Activation --
@ -466,6 +466,8 @@ package body System.Tasking.Restricted.Stages is
Task_Image : String;
Created_Task : Task_Id)
is
pragma Unreferenced (Chain);
Self_ID : constant Task_Id := STPO.Self;
Base_Priority : System.Any_Priority;
Base_CPU : System.Multiprocessors.CPU_Range;
@ -558,8 +560,8 @@ package body System.Tasking.Restricted.Stages is
-- may be used by the operation of Ada code within the task.
SSL.Create_TSD (Created_Task.Common.Compiler_Data);
Created_Task.Common.Activation_Link := Chain.T_ID;
Chain.T_ID := Created_Task;
Created_Task.Common.Activation_Link := Tasks_Activation_Chain;
Tasks_Activation_Chain := Created_Task;
end Create_Restricted_Task;
---------------------------

23
gcc/ada/s-tarest.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -175,20 +175,11 @@ package System.Tasking.Restricted.Stages is
--
-- This procedure can raise Storage_Error if the task creation fails
procedure Activate_Restricted_Tasks
(Chain_Access : Activation_Chain_Access);
-- Compiler interface only. Do not call from within the RTS.
-- This must be called by the creator of a chain of one or more new tasks,
-- to activate them. The chain is a linked list that up to this point is
-- only known to the task that created them, though the individual tasks
-- are already in the All_Tasks_List.
--
-- The compiler builds the chain in LIFO order (as a stack). Another
-- version of this procedure had code to reverse the chain, so as to
-- activate the tasks in the order of declaration. This might be nice, but
-- it is not needed if priority-based scheduling is supported, since all
-- the activated tasks synchronize on the activators lock before they start
-- activating and so they should start activating in priority order.
procedure Activate_Tasks;
pragma Export (C, Activate_Tasks, "__gnat_activate_tasks");
-- Binder interface only. Do not call from within the RTS. This must be
-- called an the end of the elaboration to activate all tasks, in order
-- to implement the sequential elaboration policy.
procedure Complete_Restricted_Activation;
-- Compiler interface only. Do not call from within the RTS. This should be
@ -217,7 +208,7 @@ package System.Tasking.Restricted.Stages is
-- restricted_terminated (t1._task_id)
procedure Finalize_Global_Tasks;
-- This is needed to support the compiler interface; it will only be called
-- This is needed to support the compiler interface. It will only be called
-- by the Environment task in the binder generated file (by adafinal).
-- Instead, it will cause the Environment to block forever, since none of
-- the dependent tasks are expected to terminate

10
gcc/ada/sem_ch13.adb
View file

@ -5032,7 +5032,8 @@ package body Sem_Ch13 is
----------------------------
procedure Replace_Type_Reference (N : Node_Id) is
-- Use the Sloc of the usage name below, not the defining name
-- See comments in Add_Predicates.Replace_Type_Reference regarding
-- Sloc and Comes_From_Source.
begin
-- Invariant'Class, replace with T'Class (obj)
@ -5055,6 +5056,8 @@ package body Sem_Ch13 is
Set_Entity (N, Object_Entity);
Set_Etype (N, Typ);
end if;
Set_Comes_From_Source (N, True);
end Replace_Type_Reference;
-- Start of processing for Add_Invariants
@ -5442,6 +5445,11 @@ package body Sem_Ch13 is
Set_Entity (N, Object_Entity);
Set_Etype (N, Typ);
-- We want to treat the node as if it comes from source, so that
-- ASIS will not ignore it
Set_Comes_From_Source (N, True);
end Replace_Type_Reference;
-- Start of processing for Add_Predicates

50
gcc/ada/sem_ch5.adb
View file

@ -2626,6 +2626,56 @@ package body Sem_Ch5 is
Push_Scope (Ent);
Analyze_Iteration_Scheme (Iter);
-- Check for following case which merits a warning if the type E of is
-- a multi-dimensional array (and no explicit subscript ranges present).
-- for J in E'Range
-- for K in E'Range
if Present (Iter)
and then Present (Loop_Parameter_Specification (Iter))
then
declare
LPS : constant Node_Id := Loop_Parameter_Specification (Iter);
DSD : constant Node_Id :=
Original_Node (Discrete_Subtype_Definition (LPS));
begin
if Nkind (DSD) = N_Attribute_Reference
and then Attribute_Name (DSD) = Name_Range
and then No (Expressions (DSD))
then
declare
Typ : constant Entity_Id := Etype (Prefix (DSD));
begin
if Is_Array_Type (Typ)
and then Number_Dimensions (Typ) > 1
and then Nkind (Parent (N)) = N_Loop_Statement
and then Present (Iteration_Scheme (Parent (N)))
then
declare
OIter : constant Node_Id :=
Iteration_Scheme (Parent (N));
OLPS : constant Node_Id :=
Loop_Parameter_Specification (OIter);
ODSD : constant Node_Id :=
Original_Node (Discrete_Subtype_Definition (OLPS));
begin
if Nkind (ODSD) = N_Attribute_Reference
and then Attribute_Name (ODSD) = Name_Range
and then No (Expressions (ODSD))
and then Etype (Prefix (ODSD)) = Typ
then
Error_Msg_Sloc := Sloc (ODSD);
Error_Msg_N
("inner range same as outer range#?", DSD);
end if;
end;
end if;
end;
end if;
end;
end if;
-- Analyze the statements of the body except in the case of an Ada 2012
-- iterator with the expander active. In this case the expander will do
-- a rewrite of the loop into a while loop. We will then analyze the

9
gcc/ada/sem_res.adb
View file

@ -7155,12 +7155,13 @@ package body Sem_Res is
Resolve (Then_Expr, Typ);
Then_Typ := Etype (Then_Expr);
-- When the "then" expression is of a scalar type different from the
-- result type, then insert a conversion to ensure the generation of
-- a constraint check.
-- When the "then" expression is of a scalar subtype different from the
-- result subtype, then insert a conversion to ensure the generation of
-- a constraint check. The same is done for the else part below, again
-- comparing subtypes rather than base types.
if Is_Scalar_Type (Then_Typ)
and then Base_Type (Then_Typ) /= Base_Type (Typ)
and then Then_Typ /= Typ
then
Rewrite (Then_Expr, Convert_To (Typ, Then_Expr));
Analyze_And_Resolve (Then_Expr, Typ);