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

[multiple changes]

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

	* lib-xref-spark_specific.adb, par-ch13.adb, sem_prag.adb, sem_prag.ads,
	sem_ch12.adb, sem_attr.adb, sem_ch6.adb, sem_ch13.adb, a-sequio.adb,
	s-atocou-builtin.adb: Minor reformatting.

2013-10-10  Thomas Quinot  <quinot@adacore.com>

	* s-oscons-tmplt.c (NEED_PTHREAD_CONDATTR_SETCLOCK): This
	constant needs to be output to s-oscons.h, as it is tested
	by init.c.

2013-10-10  Robert Dewar  <dewar@adacore.com>

	* exp_ch3.adb (Expand_N_Variant_Part): Don't expand choices, too early
	* exp_ch5.adb (Expand_N_Case_Statement): Use new Has_SP_Choice
	flag to avoid expanding choices when not necessary.
	* exp_util.adb: Minor reformatting
	* freeze.adb (Freeze_Record_Type): Redo expansion of variants
	* sem_aggr.adb: Minor reformatting
	* sem_case.ads, sem_case.adb: Major rewrite, separating Analysis and
	Checking of choices.
	* sem_ch3.adb (Analyze_Variant_Part): Rewrite to call new
	Analyze_Choices.
	* sem_ch4.adb (Analyze_Case_Expression): Call Analyze_Choices
	and Check_Choices
	* sem_ch5.adb (Analyze_Case_Statement): Call Analyze_Choices
	and Check_Choices
	* sem_util.adb: Minor reformatting
	* sinfo.ads, sinfo.adb (Has_SP_Choice): New flag.

2013-10-10  Vincent Celier  <celier@adacore.com>

	* mlib-prj.adb (Build_Library): Do not issue link dynamic
	libraries with an Rpath, if switch -R was used.

2013-10-10  Tristan Gingold  <gingold@adacore.com>

	* s-stalib.ads (Image_Index_Table_8, Image_Index_Table_16,
	Image_Index_Table_32): Remove as not used.
	* s-imgint.adb (Image_Integer): Call Set_Image_Integer and
	remove duplicated code.

From-SVN: r203358
This commit is contained in:
Arnaud Charlet 2013-10-10 14:17:35 +02:00
parent b184c8f138
commit 1591837192
28 changed files with 689 additions and 297 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

43
gcc/ada/ChangeLog
View file

@ -1,3 +1,46 @@
2013-10-10 Robert Dewar <dewar@adacore.com>
* lib-xref-spark_specific.adb, par-ch13.adb, sem_prag.adb, sem_prag.ads,
sem_ch12.adb, sem_attr.adb, sem_ch6.adb, sem_ch13.adb, a-sequio.adb,
s-atocou-builtin.adb: Minor reformatting.
2013-10-10 Thomas Quinot <quinot@adacore.com>
* s-oscons-tmplt.c (NEED_PTHREAD_CONDATTR_SETCLOCK): This
constant needs to be output to s-oscons.h, as it is tested
by init.c.
2013-10-10 Robert Dewar <dewar@adacore.com>
* exp_ch3.adb (Expand_N_Variant_Part): Don't expand choices, too early
* exp_ch5.adb (Expand_N_Case_Statement): Use new Has_SP_Choice
flag to avoid expanding choices when not necessary.
* exp_util.adb: Minor reformatting
* freeze.adb (Freeze_Record_Type): Redo expansion of variants
* sem_aggr.adb: Minor reformatting
* sem_case.ads, sem_case.adb: Major rewrite, separating Analysis and
Checking of choices.
* sem_ch3.adb (Analyze_Variant_Part): Rewrite to call new
Analyze_Choices.
* sem_ch4.adb (Analyze_Case_Expression): Call Analyze_Choices
and Check_Choices
* sem_ch5.adb (Analyze_Case_Statement): Call Analyze_Choices
and Check_Choices
* sem_util.adb: Minor reformatting
* sinfo.ads, sinfo.adb (Has_SP_Choice): New flag.
2013-10-10 Vincent Celier <celier@adacore.com>
* mlib-prj.adb (Build_Library): Do not issue link dynamic
libraries with an Rpath, if switch -R was used.
2013-10-10 Tristan Gingold <gingold@adacore.com>
* s-stalib.ads (Image_Index_Table_8, Image_Index_Table_16,
Image_Index_Table_32): Remove as not used.
* s-imgint.adb (Image_Integer): Call Set_Image_Integer and
remove duplicated code.
2013-10-10 Hristian Kirtchev <kirtchev@adacore.com>
* sem_prag.adb (Analyze_Pragma): Provide a

16
gcc/ada/a-sequio.adb
View file

@ -35,13 +35,15 @@
-- (for specialized Sequential_IO functions)
with Ada.Unchecked_Conversion;
with System;
with System.Byte_Swapping;
with System.CRTL;
with System.File_Control_Block;
with System.File_IO;
with System.Storage_Elements;
with Interfaces.C_Streams; use Interfaces.C_Streams;
with GNAT.Byte_Swapping;
package body Ada.Sequential_IO is
@ -69,11 +71,11 @@ package body Ada.Sequential_IO is
---------------
procedure Byte_Swap (Siz : in out size_t) is
use GNAT.Byte_Swapping;
use System.Byte_Swapping;
begin
case Siz'Size is
when 32 => Swap4 (Siz'Address);
when 64 => Swap8 (Siz'Address);
when 32 => Siz := size_t (Bswap_32 (U32 (Siz)));
when 64 => Siz := size_t (Bswap_64 (U64 (Siz)));
when others => raise Program_Error;
end case;
end Byte_Swap;
@ -189,6 +191,9 @@ package body Ada.Sequential_IO is
FIO.Read_Buf
(AP (File), Rsiz'Address, size_t'Size / System.Storage_Unit);
-- If item read has non-default scalar storage order, then the size
-- will have been written with that same order, so byte swap it.
if Element_Type'Scalar_Storage_Order /= System.Default_Bit_Order then
Byte_Swap (Rsiz);
end if;
@ -288,6 +293,9 @@ package body Ada.Sequential_IO is
if not Element_Type'Definite
or else Element_Type'Has_Discriminants
then
-- If item written has non-default scalar storage order, then the
-- size is written with that same order, so byte swap it.
if Element_Type'Scalar_Storage_Order /= System.Default_Bit_Order then
Byte_Swap (Swapped_Siz);
end if;

14
gcc/ada/exp_ch3.adb
View file

@ -5849,7 +5849,6 @@ package body Exp_Ch3 is
procedure Expand_N_Variant_Part (N : Node_Id) is
Last_Var : constant Node_Id := Last_Non_Pragma (Variants (N));
Others_Node : Node_Id;
Variant : Node_Id;
begin
-- If the last variant does not contain the Others choice, replace it
@ -5866,15 +5865,12 @@ package body Exp_Ch3 is
Set_Discrete_Choices (Last_Var, New_List (Others_Node));
end if;
-- Deal with any static predicates in the variant choices. Note that we
-- don't have to look at the last variant, since we know it is an others
-- choice, because we just rewrote it that way if necessary.
-- We have one more expansion activity, which is to deal with static
-- predicates in the variant choices. But we have to defer that to
-- the freeze point, because the statically predicated subtype won't
-- be fully processed till then, so this expansion activity is carried
-- out in Freeze_Record_Type.
Variant := First_Non_Pragma (Variants (N));
while Variant /= Last_Var loop
Expand_Static_Predicates_In_Choices (Variant);
Next_Non_Pragma (Variant);
end loop;
end Expand_N_Variant_Part;
---------------------------------

6
gcc/ada/exp_ch5.adb
View file

@ -2627,7 +2627,11 @@ package body Exp_Ch5 is
Alt := First_Non_Pragma (Alternatives (N));
while Present (Alt) loop
Process_Statements_For_Controlled_Objects (Alt);
Expand_Static_Predicates_In_Choices (Alt);
if Has_SP_Choice (Alt) then
Expand_Static_Predicates_In_Choices (Alt);
end if;
Next_Non_Pragma (Alt);
end loop;
end;

2
gcc/ada/exp_util.adb
View file

@ -1991,7 +1991,7 @@ package body Exp_Util is
end if;
-- Change Sloc to referencing choice (rather than the Sloc of
-- the predicate declarationo element itself).
-- the predicate declaration element itself).
Set_Sloc (C, Sloc (Choice));
Insert_Before (Choice, C);

185
gcc/ada/freeze.adb
View file

@ -46,6 +46,7 @@ with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Case; use Sem_Case;
with Sem_Cat; use Sem_Cat;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
@ -846,8 +847,9 @@ package body Freeze is
and then Nkind (Type_Definition (Parent (T))) =
N_Record_Definition
and then not Null_Present (Type_Definition (Parent (T)))
and then Present (Variant_Part
(Component_List (Type_Definition (Parent (T)))))
and then
Present (Variant_Part
(Component_List (Type_Definition (Parent (T)))))
then
-- If variant part is present, and type is unconstrained,
-- then we must have defaulted discriminants, or a size
@ -2272,7 +2274,7 @@ package body Freeze is
begin
if Present (Alloc) then
-- If component is pointer to a classwide type, freeze
-- If component is pointer to a class-wide type, freeze
-- the specific type in the expression being allocated.
-- The expression may be a subtype indication, in which
-- case freeze the subtype mark.
@ -2367,7 +2369,8 @@ package body Freeze is
if Present (ADC) and then Base_Type (Rec) = Rec then
if not (Placed_Component or else Is_Packed (Rec)) then
Error_Msg_N ("??bit order specification has no effect", ADC);
Error_Msg_N
("??bit order specification has no effect", ADC);
Error_Msg_N
("\??since no component clauses were specified", ADC);
@ -2443,15 +2446,13 @@ package body Freeze is
-- remote type here since that is what we are semantically freezing.
-- This prevents the freeze node for that type in an inner scope.
-- Also, Check for controlled components and unchecked unions.
-- Finally, enforce the restriction that access attributes with a
-- current instance prefix can only apply to limited types.
if Ekind (Rec) = E_Record_Type then
if Present (Corresponding_Remote_Type (Rec)) then
Freeze_And_Append (Corresponding_Remote_Type (Rec), N, Result);
end if;
-- Check for controlled components and unchecked unions.
Comp := First_Component (Rec);
while Present (Comp) loop
@ -2459,18 +2460,18 @@ package body Freeze is
-- equivalent type. See Make_CW_Equivalent_Type.
if not Is_Class_Wide_Equivalent_Type (Rec)
and then (Has_Controlled_Component (Etype (Comp))
or else (Chars (Comp) /= Name_uParent
and then Is_Controlled (Etype (Comp)))
or else (Is_Protected_Type (Etype (Comp))
and then
Present
(Corresponding_Record_Type
(Etype (Comp)))
and then
Has_Controlled_Component
(Corresponding_Record_Type
(Etype (Comp)))))
and then
(Has_Controlled_Component (Etype (Comp))
or else
(Chars (Comp) /= Name_uParent
and then Is_Controlled (Etype (Comp)))
or else
(Is_Protected_Type (Etype (Comp))
and then
Present (Corresponding_Record_Type (Etype (Comp)))
and then
Has_Controlled_Component
(Corresponding_Record_Type (Etype (Comp)))))
then
Set_Has_Controlled_Component (Rec);
end if;
@ -2490,11 +2491,17 @@ package body Freeze is
end loop;
end if;
-- Enforce the restriction that access attributes with a current
-- instance prefix can only apply to limited types. This comment
-- is floating here, but does not seem to belong here???
-- Set component alignment if not otherwise already set
Set_Component_Alignment_If_Not_Set (Rec);
-- For first subtypes, check if there are any fixed-point fields with
-- component clauses, where we must check the size. This is not done
-- till the freeze point, since for fixed-point types, we do not know
-- till the freeze point since for fixed-point types, we do not know
-- the size until the type is frozen. Similar processing applies to
-- bit packed arrays.
@ -2613,6 +2620,142 @@ package body Freeze is
end;
end if;
end if;
-- All done if not a full record definition
if Ekind (Rec) /= E_Record_Type then
return;
end if;
-- Finallly we need to check the variant part to make sure that
-- the set of choices for each variant covers the corresponding
-- discriminant. This check has to be delayed to the freeze point
-- because we may have statically predicated subtypes, whose choice
-- list is not known till the subtype is frozen.
Check_Variant_Part : declare
D : constant Node_Id := Declaration_Node (Rec);
T : Node_Id;
C : Node_Id;
V : Node_Id;
Others_Present : Boolean;
pragma Warnings (Off, Others_Present);
-- Indicates others present, not used in this case
procedure Non_Static_Choice_Error (Choice : Node_Id);
-- Error routine invoked by the generic instantiation below when
-- the variant part has a non static choice.
procedure Process_Declarations (Variant : Node_Id);
-- Processes declarations associated with a variant. We analyzed
-- the declarations earlier (in Sem_Ch3.Analyze_Variant_Part),
-- but we still need the recursive call to Check_Choices for any
-- nested variant to get its choices properly processed. This is
-- also where we expand out the choices if expansion is active.
package Variant_Choices_Processing is new
Generic_Check_Choices
(Process_Empty_Choice => No_OP,
Process_Non_Static_Choice => Non_Static_Choice_Error,
Process_Associated_Node => Process_Declarations);
use Variant_Choices_Processing;
-----------------------------
-- Non_Static_Choice_Error --
-----------------------------
procedure Non_Static_Choice_Error (Choice : Node_Id) is
begin
Flag_Non_Static_Expr
("choice given in variant part is not static!", Choice);
end Non_Static_Choice_Error;
--------------------------
-- Process_Declarations --
--------------------------
procedure Process_Declarations (Variant : Node_Id) is
CL : constant Node_Id := Component_List (Variant);
VP : Node_Id;
begin
-- Check for static predicate present in this variant
if Has_SP_Choice (Variant) then
-- Here we expand. You might expect to find this call in
-- Expand_N_Variant_Part, but that is called when we first
-- see the variant part, and we cannot do this expansion
-- earlier than the freeze point, since for statically
-- predicated subtypes, the predicate is not known till
-- the freeze point.
-- Furthermore, we do this expansion even if the expander
-- is not active, because other semantic processing, e.g.
-- for aggregates, requires the expanded list of choices.
-- If the expander is not active, then we can't just clobber
-- the list since it would invalidate the ASIS -gnatct tree.
-- So we have to rewrite the variant part with a Rewrite
-- call that replaces it with a copy and clobber the copy.
if not Expander_Active then
declare
NewV : constant Node_Id := New_Copy (Variant);
begin
Set_Discrete_Choices
(NewV, New_Copy_List (Discrete_Choices (Variant)));
Rewrite (Variant, NewV);
end;
end if;
Expand_Static_Predicates_In_Choices (Variant);
end if;
-- We don't need to worry about the declarations in the variant
-- (since they were analyzed by Analyze_Choices when we first
-- encountered the variant), but we do need to take care of
-- expansion of any nested variants.
if not Null_Present (CL) then
VP := Variant_Part (CL);
if Present (VP) then
Check_Choices
(VP, Variants (VP), Etype (Name (VP)), Others_Present);
end if;
end if;
end Process_Declarations;
-- Start of processing for Check_Variant_Part
begin
-- Find component list
C := Empty;
if Nkind (D) = N_Full_Type_Declaration then
T := Type_Definition (D);
if Nkind (T) = N_Record_Definition then
C := Component_List (T);
elsif Nkind (T) = N_Derived_Type_Definition
and then Present (Record_Extension_Part (T))
then
C := Component_List (Record_Extension_Part (T));
end if;
end if;
-- If we have a variant part, check choices
if Present (C) and then Present (Variant_Part (C)) then
V := Variant_Part (C);
Check_Choices
(V, Variants (V), Etype (Name (V)), Others_Present);
end if;
end Check_Variant_Part;
end Freeze_Record_Type;
-- Start of processing for Freeze_Entity

9
gcc/ada/lib-xref-spark_specific.adb
View file

@ -1022,11 +1022,10 @@ package body SPARK_Specific is
when N_Pragma =>
-- The enclosing subprogram for a precondition, a
-- postcondition, or a contract case should be the subprogram
-- to which the pragma is attached, which can be found by
-- following previous elements in the list to which the
-- pragma belongs.
-- The enclosing subprogram for a precondition, postcondition,
-- or contract case should be the subprogram to which the
-- pragma is attached, which can be found by following
-- previous elements in the list to which the pragma belongs.
if Get_Pragma_Id (Result) = Pragma_Precondition
or else

4
gcc/ada/mlib-prj.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2011, AdaCore --
-- Copyright (C) 2001-2013, AdaCore --
-- --
-- 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- --
@ -1651,7 +1651,7 @@ package body MLib.Prj is
-- content of Rpath. As Rpath contains at least libgnat directory
-- path name, it is guaranteed that it is not null.
if Path_Option /= null then
if Opt.Run_Path_Option and then Path_Option /= null then
Opts.Increment_Last;
Opts.Table (Opts.Last) :=
new String'(Path_Option.all & Rpath (1 .. Rpath_Last));

10
gcc/ada/par-ch13.adb
View file

@ -88,9 +88,9 @@ package body Ch13 is
Result := True;
else
Scan; -- past identifier
Result := Token = Tok_Arrow
or else Token = Tok_Comma
or else Token = Tok_Semicolon;
Result := Token = Tok_Arrow or else
Token = Tok_Comma or else
Token = Tok_Semicolon;
end if;
-- If earlier than Ada 2012, check for valid aspect identifier (possibly
@ -113,9 +113,7 @@ package body Ch13 is
-- defaulted True value. Further checks when analyzing aspect
-- specification, which may include further aspects.
elsif Token = Tok_Comma
or else Token = Tok_Semicolon
then
elsif Token = Tok_Comma or else Token = Tok_Semicolon then
Result := True;
elsif Token = Tok_Apostrophe then

4
gcc/ada/s-atocou-builtin.adb
View file

@ -64,8 +64,8 @@ package body System.Atomic_Counters is
procedure Increment (Item : in out Atomic_Counter) is
begin
-- Note: the use of Unrestricted_Access here is required because we
-- are obtaining an access-to-volatile pointer to a non-volatile object.
-- Note: the use of Unrestricted_Access here is required because we are
-- obtaining an access-to-volatile pointer to a non-volatile object.
-- This is not allowed for [Unchecked_]Access, but is safe in this case
-- because we know that no aliases are being created.

36
gcc/ada/s-imgint.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2013, 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- --
@ -42,39 +42,15 @@ package body System.Img_Int is
is
pragma Assert (S'First = 1);
procedure Set_Digits (T : Integer);
-- Set digits of absolute value of T, which is zero or negative. We work
-- with the negative of the value so that the largest negative number is
-- not a special case.
----------------
-- Set_Digits --
----------------
procedure Set_Digits (T : Integer) is
begin
if T <= -10 then
Set_Digits (T / 10);
P := P + 1;
S (P) := Character'Val (48 - (T rem 10));
else
P := P + 1;
S (P) := Character'Val (48 - T);
end if;
end Set_Digits;
-- Start of processing for Image_Integer
begin
P := 1;
if V >= 0 then
S (P) := ' ';
Set_Digits (-V);
S (1) := ' ';
P := 1;
else
S (P) := '-';
Set_Digits (V);
P := 0;
end if;
Set_Image_Integer (V, S, P);
end Image_Integer;
-----------------------

7
gcc/ada/s-oscons-tmplt.c
View file

@ -7,7 +7,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2000-2012, Free Software Foundation, Inc. --
-- Copyright (C) 2000-2013, 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- --
@ -1420,7 +1420,7 @@ CND(CLOCK_THREAD_CPUTIME_ID, "Thread CPU clock")
** appropriately (see thread.c).
**/
# define CLOCK_RT_Ada "CLOCK_MONOTONIC"
# define NEED_PTHREAD_CONDATTR_SETCLOCK
# define NEED_PTHREAD_CONDATTR_SETCLOCK 1
#elif defined(HAVE_CLOCK_REALTIME)
/* By default use CLOCK_REALTIME */
@ -1430,6 +1430,9 @@ CND(CLOCK_THREAD_CPUTIME_ID, "Thread CPU clock")
#ifdef CLOCK_RT_Ada
CNS(CLOCK_RT_Ada, "")
#endif
#ifdef NEED_PTHREAD_CONDATTR_SETCLOCK
CND(NEED_PTHREAD_CONDATTR_SETCLOCK, "")
#endif
#if defined (__APPLE__) || defined (__linux__) || defined (DUMMY)
/*

22
gcc/ada/s-stalib.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2013, 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- --
@ -74,26 +74,6 @@ package System.Standard_Library is
function To_Ptr is
new Ada.Unchecked_Conversion (System.Address, Big_String_Ptr);
---------------------------------------------
-- Type For Enumeration Image Index Tables --
---------------------------------------------
-- Note: these types are declared at the start of this unit, since
-- they must appear before any enumeration types declared in this
-- unit. Note that the spec of system is already elaborated at
-- this point (since we are a child of system), which means that
-- enumeration types in package System cannot use these types.
type Image_Index_Table_8 is
array (Integer range <>) of Short_Short_Integer;
type Image_Index_Table_16 is
array (Integer range <>) of Short_Integer;
type Image_Index_Table_32 is
array (Integer range <>) of Integer;
-- These types are used to generate the index vector used for enumeration
-- type image tables. See spec of Exp_Imgv in the main GNAT sources for a
-- full description of the data structures that are used here.
-------------------------------------
-- Exception Declarations and Data --
-------------------------------------

33
gcc/ada/sem_aggr.adb
View file

@ -3416,6 +3416,7 @@ package body Sem_Aggr is
begin
-- A record aggregate is restricted in SPARK:
-- Each named association can have only a single choice.
-- OTHERS cannot be used.
-- Positional and named associations cannot be mixed.
@ -3758,6 +3759,8 @@ package body Sem_Aggr is
end loop;
end Find_Private_Ancestor;
-- Start of processing for Step_5
begin
if Is_Derived_Type (Typ) and then Is_Tagged_Type (Typ) then
Parent_Typ_List := New_Elmt_List;
@ -3822,11 +3825,12 @@ package body Sem_Aggr is
if Nkind (Dnode) = N_Full_Type_Declaration then
Record_Def := Type_Definition (Dnode);
Gather_Components (Base_Type (Typ),
Component_List (Record_Def),
Governed_By => New_Assoc_List,
Into => Components,
Report_Errors => Errors_Found);
Gather_Components
(Base_Type (Typ),
Component_List (Record_Def),
Governed_By => New_Assoc_List,
Into => Components,
Report_Errors => Errors_Found);
end if;
end if;
@ -3915,19 +3919,20 @@ package body Sem_Aggr is
null;
elsif not Has_Unknown_Discriminants (Typ) then
Gather_Components (Base_Type (Typ),
Component_List (Record_Def),
Governed_By => New_Assoc_List,
Into => Components,
Report_Errors => Errors_Found);
Gather_Components
(Base_Type (Typ),
Component_List (Record_Def),
Governed_By => New_Assoc_List,
Into => Components,
Report_Errors => Errors_Found);
else
Gather_Components
(Base_Type (Underlying_Record_View (Typ)),
Component_List (Record_Def),
Governed_By => New_Assoc_List,
Into => Components,
Report_Errors => Errors_Found);
Component_List (Record_Def),
Governed_By => New_Assoc_List,
Into => Components,
Report_Errors => Errors_Found);
end if;
end if;

5
gcc/ada/sem_attr.adb
View file

@ -5041,7 +5041,8 @@ package body Sem_Attr is
when Attribute_Scalar_Storage_Order => Scalar_Storage_Order :
declare
Ent : Entity_Id := Empty;
Ent : Entity_Id := Empty;
begin
Check_E0;
Check_Type;
@ -5053,7 +5054,7 @@ package body Sem_Attr is
-- the default bit order for the target.
if not (GNAT_Mode and then Is_Generic_Type (P_Type))
and then not In_Instance
and then not In_Instance
then
Error_Attr_P
("prefix of % attribute must be record or array type");

228
gcc/ada/sem_case.adb
View file

@ -26,6 +26,8 @@
with Atree; use Atree;
with Einfo; use Einfo;
with Errout; use Errout;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
@ -65,7 +67,7 @@ package body Sem_Case is
-- Local Subprograms --
-----------------------
procedure Check_Choices
procedure Check_Choice_Set
(Choice_Table : in out Choice_Table_Type;
Bounds_Type : Entity_Id;
Subtyp : Entity_Id;
@ -95,7 +97,7 @@ package body Sem_Case is
(Case_Table : Choice_Table_Type;
Others_Choice : Node_Id;
Choice_Type : Entity_Id);
-- The case table is the table generated by a call to Analyze_Choices
-- The case table is the table generated by a call to Check_Choices
-- (with just 1 .. Last_Choice entries present). Others_Choice is a
-- pointer to the N_Others_Choice node (this routine is only called if
-- an others choice is present), and Choice_Type is the discrete type
@ -103,11 +105,11 @@ package body Sem_Case is
-- determine the set of values covered by others. This choice list is
-- set in the Others_Discrete_Choices field of the N_Others_Choice node.
-------------------
-- Check_Choices --
-------------------
----------------------
-- Check_Choice_Set --
----------------------
procedure Check_Choices
procedure Check_Choice_Set
(Choice_Table : in out Choice_Table_Type;
Bounds_Type : Entity_Id;
Subtyp : Entity_Id;
@ -598,7 +600,7 @@ package body Sem_Case is
Prev_Lo : Uint;
Prev_Hi : Uint;
-- Start of processing for Check_Choices
-- Start of processing for Check_Choice_Set
begin
-- Choice_Table must start at 0 which is an unused location used by the
@ -714,7 +716,7 @@ package body Sem_Case is
end if;
end if;
end if;
end Check_Choices;
end Check_Choice_Set;
------------------
-- Choice_Image --
@ -799,11 +801,10 @@ package body Sem_Case is
Previous_Hi : Uint;
function Build_Choice (Value1, Value2 : Uint) return Node_Id;
-- Builds a node representing the missing choices given by the
-- Value1 and Value2. A N_Range node is built if there is more than
-- one literal value missing. Otherwise a single N_Integer_Literal,
-- N_Identifier or N_Character_Literal is built depending on what
-- Choice_Type is.
-- Builds a node representing the missing choices given by Value1 and
-- Value2. A N_Range node is built if there is more than one literal
-- value missing. Otherwise a single N_Integer_Literal, N_Identifier
-- or N_Character_Literal is built depending on what Choice_Type is.
function Lit_Of (Value : Uint) return Node_Id;
-- Returns the Node_Id for the enumeration literal corresponding to the
@ -975,11 +976,131 @@ package body Sem_Case is
null;
end No_OP;
--------------------------------
-- Generic_Choices_Processing --
--------------------------------
-----------------------------
-- Generic_Analyze_Choices --
-----------------------------
package body Generic_Choices_Processing is
package body Generic_Analyze_Choices is
-- The following type is used to gather the entries for the choice
-- table, so that we can then allocate the right length.
type Link;
type Link_Ptr is access all Link;
type Link is record
Val : Choice_Bounds;
Nxt : Link_Ptr;
end record;
---------------------
-- Analyze_Choices --
---------------------
procedure Analyze_Choices
(Alternatives : List_Id;
Subtyp : Entity_Id)
is
Choice_Type : constant Entity_Id := Base_Type (Subtyp);
-- The actual type against which the discrete choices are resolved.
-- Note that this type is always the base type not the subtype of the
-- ruling expression, index or discriminant.
Expected_Type : Entity_Id;
-- The expected type of each choice. Equal to Choice_Type, except if
-- the expression is universal, in which case the choices can be of
-- any integer type.
Alt : Node_Id;
-- A case statement alternative or a variant in a record type
-- declaration.
Choice : Node_Id;
Kind : Node_Kind;
-- The node kind of the current Choice
begin
-- Set Expected type (= choice type except for universal integer,
-- where we accept any integer type as a choice).
if Choice_Type = Universal_Integer then
Expected_Type := Any_Integer;
else
Expected_Type := Choice_Type;
end if;
-- Now loop through the case alternatives or record variants
Alt := First (Alternatives);
while Present (Alt) loop
-- If pragma, just analyze it
if Nkind (Alt) = N_Pragma then
Analyze (Alt);
-- Otherwise we have an alternative. In most cases the semantic
-- processing leaves the list of choices unchanged
-- Check each choice against its base type
else
Choice := First (Discrete_Choices (Alt));
while Present (Choice) loop
Analyze (Choice);
Kind := Nkind (Choice);
-- Choice is a Range
if Kind = N_Range
or else (Kind = N_Attribute_Reference
and then Attribute_Name (Choice) = Name_Range)
then
Resolve (Choice, Expected_Type);
-- Choice is a subtype name, nothing further to do now
elsif Is_Entity_Name (Choice)
and then Is_Type (Entity (Choice))
then
null;
-- Choice is a subtype indication
elsif Kind = N_Subtype_Indication then
Resolve_Discrete_Subtype_Indication
(Choice, Expected_Type);
-- Others choice, no analysis needed
elsif Kind = N_Others_Choice then
null;
-- Only other possibility is an expression
else
Resolve (Choice, Expected_Type);
end if;
-- Move to next choice
Next (Choice);
end loop;
Process_Associated_Node (Alt);
end if;
Next (Alt);
end loop;
end Analyze_Choices;
end Generic_Analyze_Choices;
---------------------------
-- Generic_Check_Choices --
---------------------------
package body Generic_Check_Choices is
-- The following type is used to gather the entries for the choice
-- table, so that we can then allocate the right length.
@ -994,18 +1115,21 @@ package body Sem_Case is
procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr);
---------------------
-- Analyze_Choices --
---------------------
-------------------
-- Check_Choices --
-------------------
procedure Analyze_Choices
(N : Node_Id;
Subtyp : Entity_Id;
Raises_CE : out Boolean;
Others_Present : out Boolean)
procedure Check_Choices
(N : Node_Id;
Alternatives : List_Id;
Subtyp : Entity_Id;
Others_Present : out Boolean)
is
E : Entity_Id;
Raises_CE : Boolean;
-- Set True if one of the bounds of a choice raises CE
Enode : Node_Id;
-- This is where we post error messages for bounds out of range
@ -1042,9 +1166,6 @@ package body Sem_Case is
Kind : Node_Kind;
-- The node kind of the current Choice
Delete_Choice : Boolean;
-- Set to True to delete the current choice
Others_Choice : Node_Id := Empty;
-- Remember others choice if it is present (empty otherwise)
@ -1166,12 +1287,22 @@ package body Sem_Case is
Num_Choices := Num_Choices + 1;
end Check;
-- Start of processing for Analyze_Choices
-- Start of processing for Check_Choices
begin
Raises_CE := False;
Others_Present := False;
-- If Subtyp is not a discrete type or there was some other error,
-- then don't try any semantic checking on the choices since we have
-- a complete mess.
if not Is_Discrete_Type (Subtyp)
or else Subtyp = Any_Type
then
return;
end if;
-- If Subtyp is not a static subtype Ada 95 requires then we use the
-- bounds of its base type to determine the values covered by the
-- discrete choices.
@ -1210,7 +1341,7 @@ package body Sem_Case is
-- Now loop through the case alternatives or record variants
Alt := First (Get_Alternatives (N));
Alt := First (Alternatives);
while Present (Alt) loop
-- If pragma, just analyze it
@ -1226,7 +1357,6 @@ package body Sem_Case is
else
Choice := First (Discrete_Choices (Alt));
while Present (Choice) loop
Delete_Choice := False;
Analyze (Choice);
Kind := Nkind (Choice);
@ -1244,9 +1374,19 @@ package body Sem_Case is
elsif Is_Entity_Name (Choice)
and then Is_Type (Entity (Choice))
then
-- We have to make sure the subtype is frozen, it must be
-- before we can do the following analyses on choices!
Insert_Actions
(N, Freeze_Entity (Entity (Choice), Choice));
-- Check for inappropriate type
if not Covers (Expected_Type, Etype (Choice)) then
Wrong_Type (Choice, Choice_Type);
-- Type is OK, so check further
else
E := Entity (Choice);
@ -1285,6 +1425,8 @@ package body Sem_Case is
Next (P);
end loop;
end;
Set_Has_SP_Choice (Alt);
end if;
-- Not predicated subtype case
@ -1318,7 +1460,8 @@ package body Sem_Case is
else
if Is_OK_Static_Expression (L)
and then Is_OK_Static_Expression (H)
and then
Is_OK_Static_Expression (H)
then
if Expr_Value (L) > Expr_Value (H) then
Process_Empty_Choice (Choice);
@ -1348,7 +1491,7 @@ package body Sem_Case is
elsif Kind = N_Others_Choice then
if not (Choice = First (Discrete_Choices (Alt))
and then Choice = Last (Discrete_Choices (Alt))
and then Alt = Last (Get_Alternatives (N)))
and then Alt = Last (Alternatives))
then
Error_Msg_N
("the choice OTHERS must appear alone and last",
@ -1366,18 +1509,9 @@ package body Sem_Case is
Check (Choice, Choice, Choice);
end if;
-- Move to next choice, deleting the current one if the
-- flag requesting this deletion is set True.
-- Move to next choice
declare
C : constant Node_Id := Choice;
begin
Next (Choice);
if Delete_Choice then
Remove (C);
end if;
end;
Next (Choice);
end loop;
Process_Associated_Node (Alt);
@ -1407,7 +1541,7 @@ package body Sem_Case is
end loop;
end;
Check_Choices
Check_Choice_Set
(Choice_Table,
Bounds_Type,
Subtyp,
@ -1426,8 +1560,8 @@ package body Sem_Case is
Choice_Type => Bounds_Type);
end if;
end;
end Analyze_Choices;
end Check_Choices;
end Generic_Choices_Processing;
end Generic_Check_Choices;
end Sem_Case;

118
gcc/ada/sem_case.ads
View file

@ -30,52 +30,124 @@
-- aggregate case, since issues with nested aggregates make that case
-- substantially different.
-- The following processing is required for such cases:
-- 1. Analysis of names of subtypes, constants, expressions appearing within
-- the choices. This must be done when the construct is encountered to get
-- proper visibility of names.
-- 2. Checking for semantic correctness of the choices. A lot of this could
-- be done at the time when the construct is encountered, but not all, since
-- in the case of variants, statically predicated subtypes won't be frozen
-- (and the choice sets known) till the enclosing record type is frozen. So
-- at least the check for no overlaps and covering the range must be delayed
-- till the freeze point in this case.
-- 3. Set the Others_Discrete_Choices list for an others choice. This is
-- used in various ways, e.g. to construct the disriminant checking function
-- for the case of a variant with an others choice.
-- 4. In the case of static predicates, we need to expand out choices that
-- correspond to the predicate for the back end. This expansion destroys
-- the list of choices, so it should be delayed to expansion time. We do
-- not want to mess up the -gnatct ASIS tree, which needs to be able to
-- Step 1 is performed by the generic procedure Analyze_Choices, which is
-- called when the variant record or case statement/expression is first
-- encountered.
-- Step 2 is performed by the generic procedure Check_Choices. We decide to
-- do all semantic checking in that step, since as noted above some of this
-- has to be deferred to the freeze point in any case for variants. For case
-- statements and expressions, this procedure can be called at the time the
-- case construct is encountered (after calling Analyze_Choices).
-- Step 3 is also performed by Check_Choices, since we need the static ranges
-- for predicated subtypes to accurately construct this.
-- Step 4 is performed by the procedure Expand_Static_Predicates_In_Choices.
-- For case statements, this call only happens during expansion, so the tree
-- generated for ASIS does not have this expansion. For the Variant case, the
-- expansion is done in the ASIS -gnatct case, but with a proper Rewrite call
-- on the N_Variant node, so ASIS can retrieve the original. The reason we do
-- the expansion unconditionally for variants is that other processing, for
-- example for aggregates, relies on having a complete list of choices.
-- Historical note: We used to perform all four of these functions at once in
-- a single procedure called Analyze_Choices. This routine was called at the
-- time the construct was first encountered. That seemed to work OK up to Ada
-- 2005, but the introduction of statically predicated subtypes with delayed
-- evaluation of the static ranges made this completely wrong, both because
-- the ASIS tree got destroyed by step 4, and steps 2 and 3 were too early
-- in the variant record case.
with Types; use Types;
package Sem_Case is
procedure No_OP (C : Node_Id);
-- The no-operation routine. Does absolutely nothing. Can be used
-- in the following generic for the parameter Process_Empty_Choice.
-- in the following generics for the parameters Process_Empty_Choice,
-- or Process_Associated_Node.
generic
with function Get_Alternatives (N : Node_Id) return List_Id;
-- Function used to get the list of case statement alternatives or
-- record variants, from which we can then access the actual lists of
-- discrete choices. N is the node for the original construct (case
-- statement or a record variant).
with procedure Process_Associated_Node (A : Node_Id);
-- Associated with each case alternative or record variant A there is
-- a node or list of nodes that need additional processing. This routine
-- implements that processing.
package Generic_Analyze_Choices is
procedure Analyze_Choices
(Alternatives : List_Id;
Subtyp : Entity_Id);
-- From a case expression, case statement, or record variant, this
-- routine analyzes the corresponding list of discrete choices which
-- appear in each element of the list Alternatives (for the variant
-- part case, this is the variants, for a case expression or statement,
-- this is the Alternatives).
--
-- Subtyp is the subtype of the discrete choices. The type against which
-- the discrete choices must be resolved is its base type.
end Generic_Analyze_Choices;
generic
with procedure Process_Empty_Choice (Choice : Node_Id);
-- Processing to carry out for an empty Choice. Set to No_Op (declared
-- above) if no such processing is required.
with procedure Process_Non_Static_Choice (Choice : Node_Id);
-- Processing to carry out for a non static Choice
-- Processing to carry out for a non static Choice (gives an error msg)
with procedure Process_Associated_Node (A : Node_Id);
-- Associated with each case alternative or record variant A there is
-- a node or list of nodes that need semantic processing. This routine
-- implements that processing.
package Generic_Choices_Processing is
package Generic_Check_Choices is
procedure Analyze_Choices
(N : Node_Id;
Subtyp : Entity_Id;
Raises_CE : out Boolean;
Others_Present : out Boolean);
procedure Check_Choices
(N : Node_Id;
Alternatives : List_Id;
Subtyp : Entity_Id;
Others_Present : out Boolean);
-- From a case expression, case statement, or record variant N, this
-- routine analyzes the corresponding list of discrete choices. Subtyp
-- is the subtype of the discrete choices. The type against which the
-- discrete choices must be resolved is its base type.
-- routine analyzes the corresponding list of discrete choices which
-- appear in each element of the list Alternatives (for the variant
-- part case, this is the variants, for a case expression or statement,
-- this is the Alternatives).
--
-- If one of the bounds of a discrete choice raises a constraint
-- error the flag Raise_CE is set.
-- Subtyp is the subtype of the discrete choices. The type against which
-- the discrete choices must be resolved is its base type.
--
-- Finally Others_Present is set to True if an Others choice is present
-- in the list of choices, and in this case the call also sets
-- Others_Discrete_Choices in the N_Others_Choice node.
end Generic_Choices_Processing;
-- Others_Present is set to True if an Others choice is present in the
-- list of choices, and in this case Others_Discrete_Choices is set in
-- the N_Others_Choice node.
--
-- If a Discrete_Choice list contains at least one instance of a subtype
-- with a static predicate, then the Has_SP_Choice flag is set true in
-- the parent node (N_Variant, N_Case_Expression/Statement_Alternative).
end Generic_Check_Choices;
end Sem_Case;

6
gcc/ada/sem_ch12.adb
View file

@ -3717,8 +3717,7 @@ package body Sem_Ch12 is
(Unit_Requires_Body (Gen_Unit)
or else Enclosing_Body_Present
or else Present (Corresponding_Body (Gen_Decl)))
and then (Is_In_Main_Unit (N)
or else Might_Inline_Subp)
and then (Is_In_Main_Unit (N) or else Might_Inline_Subp)
and then not Is_Actual_Pack
and then not Inline_Now
and then (Operating_Mode = Generate_Code
@ -3728,8 +3727,7 @@ package body Sem_Ch12 is
-- If front_end_inlining is enabled, do not instantiate body if
-- within a generic context.
if (Front_End_Inlining
and then not Expander_Active)
if (Front_End_Inlining and then not Expander_Active)
or else Is_Generic_Unit (Cunit_Entity (Main_Unit))
then
Needs_Body := False;

2
gcc/ada/sem_ch13.adb
View file

@ -7790,7 +7790,7 @@ package body Sem_Ch13 is
Aspect_Precondition |
Aspect_Refined_Pre |
Aspect_SPARK_Mode |
Aspect_Test_Case =>
Aspect_Test_Case =>
raise Program_Error;
end case;

84
gcc/ada/sem_ch3.adb
View file

@ -4590,60 +4590,31 @@ package body Sem_Ch3 is
--------------------------
procedure Analyze_Variant_Part (N : Node_Id) is
procedure Non_Static_Choice_Error (Choice : Node_Id);
-- Error routine invoked by the generic instantiation below when the
-- variant part has a non static choice.
procedure Process_Declarations (Variant : Node_Id);
-- Analyzes all the declarations associated with a Variant. Needed by
-- the generic instantiation below.
package Variant_Choices_Processing is new
Generic_Choices_Processing
(Get_Alternatives => Variants,
Process_Empty_Choice => No_OP,
Process_Non_Static_Choice => Non_Static_Choice_Error,
Process_Associated_Node => Process_Declarations);
use Variant_Choices_Processing;
-- Instantiation of the generic choice processing package
-----------------------------
-- Non_Static_Choice_Error --
-----------------------------
procedure Non_Static_Choice_Error (Choice : Node_Id) is
begin
Flag_Non_Static_Expr
("choice given in variant part is not static!", Choice);
end Non_Static_Choice_Error;
--------------------------
-- Process_Declarations --
--------------------------
procedure Process_Declarations (Variant : Node_Id) is
begin
if not Null_Present (Component_List (Variant)) then
Analyze_Declarations (Component_Items (Component_List (Variant)));
if Present (Variant_Part (Component_List (Variant))) then
Analyze (Variant_Part (Component_List (Variant)));
end if;
end if;
end Process_Declarations;
-- Local Variables
Discr_Name : Node_Id;
Discr_Type : Entity_Id;
Dont_Care : Boolean;
Others_Present : Boolean := False;
procedure Process_Variant (A : Node_Id);
-- Analyze declarations for a single variant
pragma Warnings (Off, Dont_Care);
pragma Warnings (Off, Others_Present);
-- We don't care about the assigned values of any of these
package Analyze_Variant_Choices is
new Generic_Analyze_Choices (Process_Variant);
use Analyze_Variant_Choices;
---------------------
-- Process_Variant --
---------------------
procedure Process_Variant (A : Node_Id) is
CL : constant Node_Id := Component_List (A);
begin
if not Null_Present (CL) then
Analyze_Declarations (Component_Items (CL));
if Present (Variant_Part (CL)) then
Analyze (Variant_Part (CL));
end if;
end if;
end Process_Variant;
-- Start of processing for Analyze_Variant_Part
@ -4672,9 +4643,18 @@ package body Sem_Ch3 is
return;
end if;
-- Call the instantiated Analyze_Choices which does the rest of the work
-- Now analyze the choices, which also analyzes the declarations that
-- are associated with each choice.
Analyze_Choices (Variants (N), Discr_Type);
-- Note: we used to instantiate and call Check_Choices here to check
-- that the choices covered the discriminant, but it's too early to do
-- that because of statically predicated subtypes, whose analysis may
-- be deferred to their freeze point which may be as late as the freeze
-- point of the containing record. So this call is now to be found in
-- Freeze_Record_Declaration.
Analyze_Choices (N, Discr_Type, Dont_Care, Others_Present);
end Analyze_Variant_Part;
----------------------------

25
gcc/ada/sem_ch4.adb
View file

@ -1315,13 +1315,17 @@ package body Sem_Ch4 is
-- Error routine invoked by the generic instantiation below when
-- the case expression has a non static choice.
package Case_Choices_Processing is new
Generic_Choices_Processing
(Get_Alternatives => Alternatives,
Process_Empty_Choice => No_OP,
package Case_Choices_Analysis is new
Generic_Analyze_Choices
(Process_Associated_Node => No_OP);
use Case_Choices_Analysis;
package Case_Choices_Checking is new
Generic_Check_Choices
(Process_Empty_Choice => No_OP,
Process_Non_Static_Choice => Non_Static_Choice_Error,
Process_Associated_Node => No_OP);
use Case_Choices_Processing;
use Case_Choices_Checking;
--------------------------
-- Has_Static_Predicate --
@ -1363,8 +1367,8 @@ package body Sem_Ch4 is
Exp_Type : Entity_Id;
Exp_Btype : Entity_Id;
Dont_Care : Boolean;
Others_Present : Boolean;
-- Indicates if Others was present
-- Start of processing for Analyze_Case_Expression
@ -1427,9 +1431,7 @@ package body Sem_Ch4 is
-- If error already reported by Resolve, nothing more to do
if Exp_Btype = Any_Discrete
or else Exp_Btype = Any_Type
then
if Exp_Btype = Any_Discrete or else Exp_Btype = Any_Type then
return;
elsif Exp_Btype = Any_Character then
@ -1461,10 +1463,11 @@ package body Sem_Ch4 is
then
null;
-- Call instantiated Analyze_Choices which does the rest of the work
-- Call Analyze_Choices and Check_Choices to do the rest of the work
else
Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present);
Analyze_Choices (Alternatives (N), Exp_Type);
Check_Choices (N, Alternatives (N), Exp_Type, Others_Present);
end if;
if Exp_Type = Universal_Integer and then not Others_Present then

45
gcc/ada/sem_ch5.adb
View file

@ -1018,12 +1018,12 @@ package body Sem_Ch5 is
Exp_Type : Entity_Id;
Exp_Btype : Entity_Id;
Last_Choice : Nat;
Dont_Care : Boolean;
Others_Present : Boolean;
-- Indicates if Others was present
pragma Warnings (Off, Last_Choice);
pragma Warnings (Off, Dont_Care);
-- Don't care about assigned values
-- Don't care about assigned value
Statements_Analyzed : Boolean := False;
-- Set True if at least some statement sequences get analyzed. If False
@ -1039,16 +1039,21 @@ package body Sem_Ch5 is
-- case statement has a non static choice.
procedure Process_Statements (Alternative : Node_Id);
-- Analyzes all the statements associated with a case alternative.
-- Needed by the generic instantiation below.
-- Analyzes the statements associated with a case alternative. Needed
-- by instantiation below.
package Case_Choices_Processing is new
Generic_Choices_Processing
(Get_Alternatives => Alternatives,
Process_Empty_Choice => No_OP,
package Analyze_Case_Choices is new
Generic_Analyze_Choices
(Process_Associated_Node => Process_Statements);
use Analyze_Case_Choices;
-- Instantiation of the generic choice analysis package
package Check_Case_Choices is new
Generic_Check_Choices
(Process_Empty_Choice => No_OP,
Process_Non_Static_Choice => Non_Static_Choice_Error,
Process_Associated_Node => Process_Statements);
use Case_Choices_Processing;
Process_Associated_Node => No_Op);
use Check_Case_Choices;
-- Instantiation of the generic choice processing package
-----------------------------
@ -1154,9 +1159,7 @@ package body Sem_Ch5 is
-- If error already reported by Resolve, nothing more to do
if Exp_Btype = Any_Discrete
or else Exp_Btype = Any_Type
then
if Exp_Btype = Any_Discrete or else Exp_Btype = Any_Type then
return;
elsif Exp_Btype = Any_Character then
@ -1185,12 +1188,12 @@ package body Sem_Ch5 is
Exp_Type := Exp_Btype;
end if;
-- Call instantiated Analyze_Choices which does the rest of the work
-- Call instantiated procedures to analyzwe and check discrete choices
Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present);
Analyze_Choices (Alternatives (N), Exp_Type);
Check_Choices (N, Alternatives (N), Exp_Type, Others_Present);
-- A case statement with a single OTHERS alternative is not allowed
-- in SPARK.
-- Case statement with single OTHERS alternative not allowed in SPARK
if Others_Present and then List_Length (Alternatives (N)) = 1 then
Check_SPARK_Restriction
@ -1213,6 +1216,12 @@ package body Sem_Ch5 is
Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
end if;
-- If the expander is active it will detect the case of a statically
-- determined single alternative and remove warnings for the case, but
-- if we are not doing expansion, that circuit won't be active. Here we
-- duplicate the effect of removing warnings in the same way, so that
-- we will get the same set of warnings in -gnatc mode.
if not Expander_Active
and then Compile_Time_Known_Value (Expression (N))
and then Serious_Errors_Detected = 0

16
gcc/ada/sem_ch6.adb
View file

@ -2867,12 +2867,9 @@ package body Sem_Ch6 is
and then Present (First_Entity (Spec_Id))
and then Ekind (Etype (First_Entity (Spec_Id))) = E_Record_Type
and then Is_Tagged_Type (Etype (First_Entity (Spec_Id)))
and then
Present (Interfaces (Etype (First_Entity (Spec_Id))))
and then
Present
(Corresponding_Concurrent_Type
(Etype (First_Entity (Spec_Id))))
and then Present (Interfaces (Etype (First_Entity (Spec_Id))))
and then Present (Corresponding_Concurrent_Type
(Etype (First_Entity (Spec_Id))))
then
declare
Typ : constant Entity_Id := Etype (First_Entity (Spec_Id));
@ -9131,9 +9128,10 @@ package body Sem_Ch6 is
------------------------
function Controlling_Formal (Prim : Entity_Id) return Entity_Id is
E : Entity_Id := First_Entity (Prim);
E : Entity_Id;
begin
E := First_Entity (Prim);
while Present (E) loop
if Is_Formal (E) and then Is_Controlling_Formal (E) then
return E;
@ -9178,8 +9176,8 @@ package body Sem_Ch6 is
-- The mode of the controlling formals must match
elsif Present (Iface_Ctrl_F)
and then Present (Prim_Ctrl_F)
and then Ekind (Iface_Ctrl_F) /= Ekind (Prim_Ctrl_F)
and then Present (Prim_Ctrl_F)
and then Ekind (Iface_Ctrl_F) /= Ekind (Prim_Ctrl_F)
then
return False;

4
gcc/ada/sem_prag.adb
View file

@ -8969,7 +8969,9 @@ package body Sem_Prag is
-- Precondition |
-- Predicate |
-- Statement_Assertions
--
-- Shouldn't Refined_Pre be in this list???
-- Note: The RM_ASSERTION_KIND list is language-defined, and the
-- ID_ASSERTION_KIND list contains implementation-defined additions
-- recognized by GNAT. The effect is to control the behavior of

4
gcc/ada/sem_prag.ads
View file

@ -32,8 +32,8 @@ with Types; use Types;
package Sem_Prag is
-- The following table lists all the user-defined pragmas that may apply to
-- a body stub.
-- The following table lists all the implementation-defined pragmas that
-- may apply to a body stub (no language defined pragmas apply).
Pragma_On_Stub_OK : constant array (Pragma_Id) of Boolean :=
(Pragma_Refined_Pre => True,

12
gcc/ada/sem_util.adb
View file

@ -5184,9 +5184,9 @@ package body Sem_Util is
Discrim := First (Choices (Assoc));
exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim)
or else (Present (Corresponding_Discriminant (Entity (Discrim)))
and then
Chars (Corresponding_Discriminant (Entity (Discrim)))
= Chars (Discrim_Name))
and then
Chars (Corresponding_Discriminant (Entity (Discrim))) =
Chars (Discrim_Name))
or else Chars (Original_Record_Component (Entity (Discrim)))
= Chars (Discrim_Name);
@ -5274,7 +5274,6 @@ package body Sem_Util is
Find_Discrete_Value : while Present (Variant) loop
Discrete_Choice := First (Discrete_Choices (Variant));
while Present (Discrete_Choice) loop
exit Find_Discrete_Value when
Nkind (Discrete_Choice) = N_Others_Choice;
@ -5305,8 +5304,8 @@ package body Sem_Util is
-- If we have found the corresponding choice, recursively add its
-- components to the Into list.
Gather_Components (Empty,
Component_List (Variant), Governed_By, Into, Report_Errors);
Gather_Components
(Empty, Component_List (Variant), Governed_By, Into, Report_Errors);
end Gather_Components;
------------------------
@ -8655,6 +8654,7 @@ package body Sem_Util is
return Is_Fully_Initialized_Variant (U);
end if;
end;
else
return False;
end if;

20
gcc/ada/sinfo.adb
View file

@ -1552,6 +1552,16 @@ package body Sinfo is
return Flag13 (N);
end Has_Self_Reference;
function Has_SP_Choice
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Case_Expression_Alternative
or else NT (N).Nkind = N_Case_Statement_Alternative
or else NT (N).Nkind = N_Variant);
return Flag15 (N);
end Has_SP_Choice;
function Has_Storage_Size_Pragma
(N : Node_Id) return Boolean is
begin
@ -4680,6 +4690,16 @@ package body Sinfo is
Set_Flag13 (N, Val);
end Set_Has_Self_Reference;
procedure Set_Has_SP_Choice
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Case_Expression_Alternative
or else NT (N).Nkind = N_Case_Statement_Alternative
or else NT (N).Nkind = N_Variant);
Set_Flag15 (N, Val);
end Set_Has_SP_Choice;
procedure Set_Has_Storage_Size_Pragma
(N : Node_Id; Val : Boolean := True) is
begin

26
gcc/ada/sinfo.ads
View file

@ -1243,6 +1243,12 @@ package Sinfo is
-- enclosing type. Such a self-reference can only appear in default-
-- initialized aggregate for a record type.
-- Has_SP_Choice (Flag15-Sem)
-- Present in all nodes containing a Discrete_Choices field (N_Variant,
-- N_Case_Expression_Alternative, N_Case_Statement_Alternative). Set to
-- True if the Discrete_Choices list has at least one occurrence of a
-- statically predicated subtype.
-- Has_Storage_Size_Pragma (Flag5-Sem)
-- A flag present in an N_Task_Definition node to flag the presence of a
-- Storage_Size pragma.
@ -3061,8 +3067,7 @@ package Sinfo is
-- VARIANT_PART ::=
-- case discriminant_DIRECT_NAME is
-- VARIANT
-- {VARIANT}
-- VARIANT {VARIANT}
-- end case;
-- Note: the variants list can contain pragmas as well as variants.
@ -3088,12 +3093,14 @@ package Sinfo is
-- Enclosing_Variant (Node2-Sem)
-- Present_Expr (Uint3-Sem)
-- Dcheck_Function (Node5-Sem)
-- Has_SP_Choice (Flag15-Sem)
-- Note: in the list of Discrete_Choices, the tree passed to the back
-- end does not have choice entries corresponding to names of statically
-- predicated subtypes. Such entries are always expanded out to the list
-- of equivalent values or ranges. The ASIS tree generated in -gnatct
-- mode does not have this expansion, and has the original choices.
-- mode also has this expansion, but done with a proper Rewrite call on
-- the N_Variant node so that ASIS can properly retrieve the original.
---------------------------------
-- 3.8.1 Discrete Choice List --
@ -4078,12 +4085,16 @@ package Sinfo is
-- Actions (List1)
-- Discrete_Choices (List4)
-- Expression (Node3)
-- Has_SP_Choice (Flag15-Sem)
-- Note: The Actions field temporarily holds any actions associated with
-- evaluation of the Expression. During expansion of the case expression
-- these actions are wrapped into an N_Expressions_With_Actions node
-- replacing the original expression.
-- Note: this node never appears in the tree passed to the back end,
-- since the expander converts case expressions into case statements.
---------------------------------
-- 4.5.9 Quantified Expression --
---------------------------------
@ -4392,6 +4403,7 @@ package Sinfo is
-- Sloc points to WHEN
-- Discrete_Choices (List4)
-- Statements (List3)
-- Has_SP_Choice (Flag15-Sem)
-- Note: in the list of Discrete_Choices, the tree passed to the back
-- end does not have choice entries corresponding to names of statically
@ -8773,6 +8785,9 @@ package Sinfo is
function Has_Self_Reference
(N : Node_Id) return Boolean; -- Flag13
function Has_SP_Choice
(N : Node_Id) return Boolean; -- Flag15
function Has_Storage_Size_Pragma
(N : Node_Id) return Boolean; -- Flag5
@ -9769,6 +9784,9 @@ package Sinfo is
procedure Set_Has_Self_Reference
(N : Node_Id; Val : Boolean := True); -- Flag13
procedure Set_Has_SP_Choice
(N : Node_Id; Val : Boolean := True); -- Flag15
procedure Set_Has_Storage_Size_Pragma
(N : Node_Id; Val : Boolean := True); -- Flag5
@ -12195,6 +12213,7 @@ package Sinfo is
pragma Inline (Has_Init_Expression);
pragma Inline (Has_Local_Raise);
pragma Inline (Has_Self_Reference);
pragma Inline (Has_SP_Choice);
pragma Inline (Has_No_Elaboration_Code);
pragma Inline (Has_Pragma_Suppress_All);
pragma Inline (Has_Private_View);
@ -12528,6 +12547,7 @@ package Sinfo is
pragma Inline (Set_Has_Private_View);
pragma Inline (Set_Has_Relative_Deadline_Pragma);
pragma Inline (Set_Has_Self_Reference);
pragma Inline (Set_Has_SP_Choice);
pragma Inline (Set_Has_Storage_Size_Pragma);
pragma Inline (Set_Has_Wide_Character);
pragma Inline (Set_Has_Wide_Wide_Character);