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

[multiple changes]

Browse Source 
2014-10-17  Robert Dewar  <dewar@adacore.com>

	* sem_util.adb: Minor reformatting.

2014-10-17  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch12.adb (Build_Function_Wrapper): Build wrappers for
	actuals that are defaulted subprograms of the formal subprogram
	declaration.

2014-10-17  Robert Dewar  <dewar@adacore.com>

	* exp_ch4.adb (Expand_N_Op_Eq): Make sure we deal with the
	implementation base type.
	* sinfo.ads: Add a note for N_Op_Eq and N_Op_Ne that record
	operands are always expanded out into component comparisons.

2014-10-17  Robert Dewar  <dewar@adacore.com>

	* s-vallli.adb: Minor comment correction.
	* s-valuti.ads: Minor comment reformatting.

2014-10-17  Robert Dewar  <dewar@adacore.com>

	* gnat_rm.texi: Document System.Atomic_Counters.
	* impunit.adb: Add System.Atomic_Counters (s-atocou.ads) to the
	list of user- accessible units added as children of System.
	* s-atocou.ads: Update comment.

2014-10-17  Arnaud Charlet  <charlet@adacore.com>

	* s-expmod.ads: Add comments.

From-SVN: r216371
This commit is contained in:
Arnaud Charlet 2014-10-17 10:42:41 +02:00
parent 38d0d6c854
commit a92230c56c
11 changed files with 196 additions and 123 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
gcc/ada/ChangeLog
View File

@ -1,3 +1,36 @@
2014-10-17 Robert Dewar <dewar@adacore.com>
* sem_util.adb: Minor reformatting.
2014-10-17 Ed Schonberg <schonberg@adacore.com>
* sem_ch12.adb (Build_Function_Wrapper): Build wrappers for
actuals that are defaulted subprograms of the formal subprogram
declaration.
2014-10-17 Robert Dewar <dewar@adacore.com>
* exp_ch4.adb (Expand_N_Op_Eq): Make sure we deal with the
implementation base type.
* sinfo.ads: Add a note for N_Op_Eq and N_Op_Ne that record
operands are always expanded out into component comparisons.
2014-10-17 Robert Dewar <dewar@adacore.com>
* s-vallli.adb: Minor comment correction.
* s-valuti.ads: Minor comment reformatting.
2014-10-17 Robert Dewar <dewar@adacore.com>
* gnat_rm.texi: Document System.Atomic_Counters.
* impunit.adb: Add System.Atomic_Counters (s-atocou.ads) to the
list of user- accessible units added as children of System.
* s-atocou.ads: Update comment.
2014-10-17 Arnaud Charlet <charlet@adacore.com>
* s-expmod.ads: Add comments.
2014-10-17 Hristian Kirtchev <kirtchev@adacore.com> 2014-10-17 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch3.adb (Build_Derived_Record_Type): Remove the propagation * sem_ch3.adb (Build_Derived_Record_Type): Remove the propagation

5
gcc/ada/exp_ch4.adb
View File

@ -7152,7 +7152,10 @@ package body Exp_Ch4 is
return; return;
end if; end if;
Typl := Base_Type (Typl); -- Now get the implementation base type (note that plain Base_Type here
-- might lead us back to the private type, which is not what we want!)
Typl := Implementation_Base_Type (Typl);
-- Equality between variant records results in a call to a routine -- Equality between variant records results in a call to a routine
-- that has conditional tests of the discriminant value(s), and hence -- that has conditional tests of the discriminant value(s), and hence

14
gcc/ada/gnat_rm.texi
View File

@ -661,6 +661,7 @@ The GNAT Library
* Interfaces.VxWorks.IO (i-vxwoio.ads):: * Interfaces.VxWorks.IO (i-vxwoio.ads)::
* System.Address_Image (s-addima.ads):: * System.Address_Image (s-addima.ads)::
* System.Assertions (s-assert.ads):: * System.Assertions (s-assert.ads)::
* System.Atomic_Counters (s-atocou.ads)::
* System.Memory (s-memory.ads):: * System.Memory (s-memory.ads)::
* System.Multiprocessors (s-multip.ads):: * System.Multiprocessors (s-multip.ads)::
* System.Multiprocessors.Dispatching_Domains (s-mudido.ads):: * System.Multiprocessors.Dispatching_Domains (s-mudido.ads)::
@ -19074,6 +19075,7 @@ of GNAT, and will generate a warning message.
* Interfaces.VxWorks.IO (i-vxwoio.ads):: * Interfaces.VxWorks.IO (i-vxwoio.ads)::
* System.Address_Image (s-addima.ads):: * System.Address_Image (s-addima.ads)::
* System.Assertions (s-assert.ads):: * System.Assertions (s-assert.ads)::
* System.Atomic_Counters (s-atocou.ads)::
* System.Memory (s-memory.ads):: * System.Memory (s-memory.ads)::
* System.Multiprocessors (s-multip.ads):: * System.Multiprocessors (s-multip.ads)::
* System.Multiprocessors.Dispatching_Domains (s-mudido.ads):: * System.Multiprocessors.Dispatching_Domains (s-mudido.ads)::
@ -20585,6 +20587,18 @@ This package provides the declaration of the exception raised
by an run-time assertion failure, as well as the routine that by an run-time assertion failure, as well as the routine that
is used internally to raise this assertion. is used internally to raise this assertion.
@node System.Atomic_Counters (s-atocou.ads)
@section @code{System.Atomic_Counters} (@file{s-atocou.ads})
@cindex @code{System.Atomic_Counters} (@file{s-atocou.ads})
@noindent
This package provides the declaration of an atomic counter type,
together with efficient routines (using hardware
synchronization primitives) for incrementing, decrementing,
and testing of these counters. This package is implemented
on most targets, including all Alpha, ia64, PowerPC, SPARC V9,
x86, and x86_64 platforms.
@node System.Memory (s-memory.ads) @node System.Memory (s-memory.ads)
@section @code{System.Memory} (@file{s-memory.ads}) @section @code{System.Memory} (@file{s-memory.ads})
@cindex @code{System.Memory} (@file{s-memory.ads}) @cindex @code{System.Memory} (@file{s-memory.ads})

1
gcc/ada/impunit.adb
View File

@ -367,6 +367,7 @@ package body Impunit is
-------------------------------------- --------------------------------------
("s-addima", F), -- System.Address_Image ("s-addima", F), -- System.Address_Image
("s-atocou", F), -- System.Atomic_Counters
("s-assert", F), -- System.Assertions ("s-assert", F), -- System.Assertions
("s-diflio", F), -- System.Dim.Float_IO ("s-diflio", F), -- System.Dim.Float_IO
("s-diinio", F), -- System.Dim.Integer_IO ("s-diinio", F), -- System.Dim.Integer_IO

11
gcc/ada/s-atocou.ads
View File

@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2011-2013, Free Software Foundation, Inc. -- -- Copyright (C) 2011-2014, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -37,8 +37,6 @@
-- - all x86 platforms -- - all x86 platforms
-- - all x86_64 platforms -- - all x86_64 platforms
-- Why isn't this package available to application programs???
package System.Atomic_Counters is package System.Atomic_Counters is
pragma Preelaborate; pragma Preelaborate;
@ -59,20 +57,19 @@ package System.Atomic_Counters is
function Decrement (Item : in out Atomic_Counter) return Boolean; function Decrement (Item : in out Atomic_Counter) return Boolean;
pragma Inline_Always (Decrement); pragma Inline_Always (Decrement);
-- Decrements value of atomic counter, returns True when value reach zero. -- Decrements value of atomic counter, returns True when value reach zero
function Is_One (Item : Atomic_Counter) return Boolean; function Is_One (Item : Atomic_Counter) return Boolean;
pragma Inline_Always (Is_One); pragma Inline_Always (Is_One);
-- Returns True when value of the atomic counter is one. -- Returns True when value of the atomic counter is one
procedure Initialize (Item : out Atomic_Counter); procedure Initialize (Item : out Atomic_Counter);
pragma Inline_Always (Initialize); pragma Inline_Always (Initialize);
-- Initialize counter by setting its value to one. This subprogram is -- Initialize counter by setting its value to one. This subprogram is
-- intended to be used in special cases when counter object can't be -- intended to be used in special cases when the counter object cannot be
-- initialized in standard way. -- initialized in standard way.
private private
type Unsigned_32 is mod 2 ** 32; type Unsigned_32 is mod 2 ** 32;
type Atomic_Counter is limited record type Atomic_Counter is limited record

12
gcc/ada/s-expmod.ads
View File

@ -32,15 +32,25 @@
-- This function performs exponentiation of a modular type with non-binary -- This function performs exponentiation of a modular type with non-binary
-- modulus values. Arithmetic is done in Long_Long_Unsigned, with explicit -- modulus values. Arithmetic is done in Long_Long_Unsigned, with explicit
-- accounting for the modulus value which is passed as the second argument. -- accounting for the modulus value which is passed as the second argument.
-- Note that 1 is a binary modulus (2**0), so the compiler should not (and
-- will not) call this function with Modulus equal to 1).
with System.Unsigned_Types; with System.Unsigned_Types;
package System.Exp_Mod is package System.Exp_Mod is
pragma Pure; pragma Pure;
use type System.Unsigned_Types.Unsigned;
subtype Power_Of_2 is System.Unsigned_Types.Unsigned with
Dynamic_Predicate =>
Power_Of_2 /= 0 and then (Power_Of_2 and (Power_Of_2 - 1)) = 0;
function Exp_Modular function Exp_Modular
(Left : System.Unsigned_Types.Unsigned; (Left : System.Unsigned_Types.Unsigned;
Modulus : System.Unsigned_Types.Unsigned; Modulus : System.Unsigned_Types.Unsigned;
Right : Natural) return System.Unsigned_Types.Unsigned; Right : Natural) return System.Unsigned_Types.Unsigned
with
Pre => Modulus /= 0 and then Modulus not in Power_Of_2,
Post => Exp_Modular'Result = Left ** Right mod Modulus;
end System.Exp_Mod; end System.Exp_Mod;

4
gcc/ada/s-vallli.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -51,7 +51,7 @@ package body System.Val_LLI is
-- Set to True if minus sign is present, otherwise to False -- Set to True if minus sign is present, otherwise to False
Start : Positive; Start : Positive;
-- Saves location of first non-blank (not used in this case) -- Saves location of first non-blank
begin begin
Scan_Sign (Str, Ptr, Max, Minus, Start); Scan_Sign (Str, Ptr, Max, Minus, Start);

28
gcc/ada/s-valuti.ads
View File

@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -43,9 +43,9 @@ package System.Val_Util is
F, L : out Integer); F, L : out Integer);
-- This procedure scans the string S setting F to be the index of the first -- This procedure scans the string S setting F to be the index of the first
-- non-blank character of S and L to be the index of the last non-blank -- non-blank character of S and L to be the index of the last non-blank
-- character of S. Any lower case characters present in S will be folded -- character of S. Any lower case characters present in S will be folded to
-- to their upper case equivalent except for character literals. If S -- their upper case equivalent except for character literals. If S consists
-- consists of entirely blanks then Constraint_Error is raised. -- of entirely blanks then Constraint_Error is raised.
-- --
-- Note: if S is the null string, F is set to S'First, L to S'Last -- Note: if S is the null string, F is set to S'First, L to S'Last
@ -60,25 +60,25 @@ package System.Val_Util is
-- last character in the string). Scan_Sign first scans out any initial -- last character in the string). Scan_Sign first scans out any initial
-- blanks, raising Constraint_Error if the field is all blank. It then -- blanks, raising Constraint_Error if the field is all blank. It then
-- checks for and skips an initial plus or minus, requiring a non-blank -- checks for and skips an initial plus or minus, requiring a non-blank
-- character to follow (Constraint_Error is raised if plus or minus -- character to follow (Constraint_Error is raised if plus or minus appears
-- appears at the end of the string or with a following blank). Minus is -- at the end of the string or with a following blank). Minus is set True
-- set True if a minus sign was skipped, and False otherwise. On exit -- if a minus sign was skipped, and False otherwise. On exit Ptr.all points
-- Ptr.all points to the character after the sign, or to the first -- to the character after the sign, or to the first non-blank character
-- non-blank character if no sign is present. Start is set to the point -- if no sign is present. Start is set to the point to the first non-blank
-- to the first non-blank character (sign or digit after it). -- character (sign or digit after it).
-- --
-- Note: if Str is null, i.e. if Max is less than Ptr, then this is a -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a
-- special case of an all-blank string, and Ptr is unchanged, and hence -- special case of an all-blank string, and Ptr is unchanged, and hence
-- is greater than Max as required in this case. Constraint_Error is -- is greater than Max as required in this case. Constraint_Error is also
-- also raised in this case. -- raised in this case.
procedure Scan_Plus_Sign procedure Scan_Plus_Sign
(Str : String; (Str : String;
Ptr : not null access Integer; Ptr : not null access Integer;
Max : Integer; Max : Integer;
Start : out Positive); Start : out Positive);
-- Same as Scan_Sign, but allows only plus, not minus. -- Same as Scan_Sign, but allows only plus, not minus. This is used for
-- This is used for modular types. -- modular types.
function Scan_Exponent function Scan_Exponent
(Str : String; (Str : String;

38
gcc/ada/sem_ch12.adb
View File

@ -1056,7 +1056,12 @@ package body Sem_Ch12 is
Actuals := New_List; Actuals := New_List;
Profile := New_List; Profile := New_List;
F := First_Formal (Entity (Actual)); if Present (Actual) then
F := First_Formal (Entity (Actual));
else
F := First_Formal (Formal);
end if;
N_Parms := 0; N_Parms := 0;
while Present (F) loop while Present (F) loop
@ -1066,16 +1071,26 @@ package body Sem_Ch12 is
New_F := Make_Temporary New_F := Make_Temporary
(Loc, Character'Val (Character'Pos ('A') + N_Parms)); (Loc, Character'Val (Character'Pos ('A') + N_Parms));
-- If a formal has a class-wide type, rewrite as the corresponding if No (Actual) then
-- attribute, because the class-wide type is not retrievable by
-- visbility. -- If formal has a class-wide type rewrite as the corresponding
-- attribute, because the class-wide type is not retrievable by
-- visbility.
if Is_Class_Wide_Type (Etype (F)) then
Parm_Type :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Class,
Prefix =>
Make_Identifier (Loc, Chars (Etype (Etype (F)))));
else
Parm_Type :=
Make_Identifier (Loc, Chars (Etype (Etype (F))));
end if;
-- If actual is present, use the type of its own formal
if Is_Class_Wide_Type (Etype (F)) then
Parm_Type :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Class,
Prefix =>
Make_Identifier (Loc, Chars (Etype (Etype (F)))));
else else
Parm_Type := New_Occurrence_Of (Etype (F), Loc); Parm_Type := New_Occurrence_Of (Etype (F), Loc);
end if; end if;
@ -1766,8 +1781,7 @@ package body Sem_Ch12 is
else else
if GNATprove_Mode if GNATprove_Mode
and then and then Present
Present
(Containing_Package_With_Ext_Axioms (Containing_Package_With_Ext_Axioms
(Defining_Entity (Analyzed_Formal))) (Defining_Entity (Analyzed_Formal)))
and then Ekind (Defining_Entity (Analyzed_Formal)) = and then Ekind (Defining_Entity (Analyzed_Formal)) =

168
gcc/ada/sem_util.adb
View File

@ -371,8 +371,7 @@ package body Sem_Util is
raise Program_Error; raise Program_Error;
end if; end if;
-- Contract items related to subprogram bodies. The applicable pragmas -- Contract items related to subprogram bodies. Applicable pragmas are:
-- are:
-- Refined_Depends -- Refined_Depends
-- Refined_Global -- Refined_Global
-- Refined_Post -- Refined_Post
@ -392,7 +391,7 @@ package body Sem_Util is
raise Program_Error; raise Program_Error;
end if; end if;
-- Contract items related to variables. The applicable pragmas are: -- Contract items related to variables. Applicable pragmas are:
-- Async_Readers -- Async_Readers
-- Async_Writers -- Async_Writers
-- Effective_Reads -- Effective_Reads
@ -801,9 +800,7 @@ package body Sem_Util is
return; return;
end if; end if;
if Is_Generic_Formal (Typ) if Is_Generic_Formal (Typ) and then Is_Discrete_Type (Typ) then
and then Is_Discrete_Type (Typ)
then
Set_No_Predicate_On_Actual (Typ); Set_No_Predicate_On_Actual (Typ);
end if; end if;
@ -1442,8 +1439,7 @@ package body Sem_Util is
pragma Assert (Has_Default_Init_Cond (Typ)); pragma Assert (Has_Default_Init_Cond (Typ));
pragma Assert (Present (Prag)); pragma Assert (Present (Prag));
-- Nothing to do if the default initial condition procedure was already -- Nothing to do if default initial condition procedure already built
-- built.
if Present (Default_Init_Cond_Procedure (Typ)) then if Present (Default_Init_Cond_Procedure (Typ)) then
return; return;
@ -1909,7 +1905,7 @@ package body Sem_Util is
return False; return False;
else else
return return
Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
and then and then
Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
end if; end if;
@ -1938,7 +1934,7 @@ package body Sem_Util is
return False; return False;
else else
return return
Cannot_Raise_Constraint_Error (Left_Opnd (Expr)) Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
and then and then
Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
end if; end if;
@ -1992,6 +1988,7 @@ package body Sem_Util is
and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
then then
-- The non-limited view is fully declared -- The non-limited view is fully declared
null; null;
else else
@ -2429,7 +2426,7 @@ package body Sem_Util is
elsif Nkind_In (Choice, N_Range, elsif Nkind_In (Choice, N_Range,
N_Subtype_Indication) N_Subtype_Indication)
or else (Is_Entity_Name (Choice) or else (Is_Entity_Name (Choice)
and then Is_Type (Entity (Choice))) and then Is_Type (Entity (Choice)))
then then
declare declare
L, H : Node_Id; L, H : Node_Id;
@ -3049,7 +3046,8 @@ package body Sem_Util is
Comes_From_Source (N) Comes_From_Source (N)
and then Is_Entity_Name (N) and then Is_Entity_Name (N)
and then (Entity (N) = Standard_True and then (Entity (N) = Standard_True
or else Entity (N) = Standard_False); or else
Entity (N) = Standard_False);
end Is_Trivial_Boolean; end Is_Trivial_Boolean;
------------------------- -------------------------
@ -4747,7 +4745,8 @@ package body Sem_Util is
-- attempt to detect partial overlap of slices. -- attempt to detect partial overlap of slices.
return Denotes_Same_Object (Lo1, Lo2) return Denotes_Same_Object (Lo1, Lo2)
and then Denotes_Same_Object (Hi1, Hi2); and then
Denotes_Same_Object (Hi1, Hi2);
end; end;
-- In the recursion, literals appear as indexes -- In the recursion, literals appear as indexes
@ -4788,7 +4787,7 @@ package body Sem_Util is
Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice) Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice)
then then
declare declare
Root1, Root2 : Node_Id; Root1, Root2 : Node_Id;
Depth1, Depth2 : Int := 0; Depth1, Depth2 : Int := 0;
begin begin
@ -4807,8 +4806,8 @@ package body Sem_Util is
Root2 := Prefix (A2); Root2 := Prefix (A2);
while not Is_Entity_Name (Root2) loop while not Is_Entity_Name (Root2) loop
if not Nkind_In if not Nkind_In (Root2, N_Selected_Component,
(Root2, N_Selected_Component, N_Indexed_Component) N_Indexed_Component)
then then
return False; return False;
else else
@ -4826,7 +4825,7 @@ package body Sem_Util is
elsif Depth1 > Depth2 then elsif Depth1 > Depth2 then
Root1 := Prefix (A1); Root1 := Prefix (A1);
for I in 1 .. Depth1 - Depth2 - 1 loop for J in 1 .. Depth1 - Depth2 - 1 loop
Root1 := Prefix (Root1); Root1 := Prefix (Root1);
end loop; end loop;
@ -4834,7 +4833,7 @@ package body Sem_Util is
else else
Root2 := Prefix (A2); Root2 := Prefix (A2);
for I in 1 .. Depth2 - Depth1 - 1 loop for J in 1 .. Depth2 - Depth1 - 1 loop
Root2 := Prefix (Root2); Root2 := Prefix (Root2);
end loop; end loop;
@ -4897,7 +4896,6 @@ package body Sem_Util is
begin begin
if Nkind (N) = N_Defining_Program_Unit_Name then if Nkind (N) = N_Defining_Program_Unit_Name then
return Name (N); return Name (N);
else else
return Prefix (N); return Prefix (N);
end if; end if;
@ -4911,7 +4909,6 @@ package body Sem_Util is
begin begin
if Nkind (N) = N_Defining_Program_Unit_Name then if Nkind (N) = N_Defining_Program_Unit_Name then
return Defining_Identifier (N); return Defining_Identifier (N);
else else
return Selector_Name (N); return Selector_Name (N);
end if; end if;
@ -6552,9 +6549,8 @@ package body Sem_Util is
if In_Spec_Expression then if In_Spec_Expression then
return Typ; return Typ;
elsif Is_Private_Type (Typ) elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then
and then not Has_Discriminants (Typ)
then
-- If the type has no discriminants, there is no subtype to -- If the type has no discriminants, there is no subtype to
-- build, even if the underlying type is discriminated. -- build, even if the underlying type is discriminated.
@ -6793,7 +6789,6 @@ package body Sem_Util is
-- For all other cases, we have a complete table of literals, and -- For all other cases, we have a complete table of literals, and
-- we simply iterate through the chain of literal until the one -- we simply iterate through the chain of literal until the one
-- with the desired position value is found. -- with the desired position value is found.
--
else else
if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
@ -7579,7 +7574,7 @@ package body Sem_Util is
elsif Default /= Unknown elsif Default /= Unknown
and then (Has_Size_Clause (Etype (Expr)) and then (Has_Size_Clause (Etype (Expr))
or else or else
Has_Alignment_Clause (Etype (Expr))) Has_Alignment_Clause (Etype (Expr)))
then then
Set_Result (Unknown); Set_Result (Unknown);
@ -7881,13 +7876,13 @@ package body Sem_Util is
-- property is enabled when the flag evaluates to True or the flag is -- property is enabled when the flag evaluates to True or the flag is
-- missing altogether. -- missing altogether.
elsif Property = Name_Async_Readers and then Is_Enabled (AR) then elsif Property = Name_Async_Readers and then Is_Enabled (AR) then
return True; return True;
elsif Property = Name_Async_Writers and then Is_Enabled (AW) then elsif Property = Name_Async_Writers and then Is_Enabled (AW) then
return True; return True;
elsif Property = Name_Effective_Reads and then Is_Enabled (ER) then elsif Property = Name_Effective_Reads and then Is_Enabled (ER) then
return True; return True;
elsif Property = Name_Effective_Writes and then Is_Enabled (EW) then elsif Property = Name_Effective_Writes and then Is_Enabled (EW) then
@ -8027,7 +8022,7 @@ package body Sem_Util is
elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then
return Has_No_Obvious_Side_Effects (Left_Opnd (N)) return Has_No_Obvious_Side_Effects (Left_Opnd (N))
and then and then
Has_No_Obvious_Side_Effects (Right_Opnd (N)); Has_No_Obvious_Side_Effects (Right_Opnd (N));
elsif Nkind (N) = N_Expression_With_Actions elsif Nkind (N) = N_Expression_With_Actions
@ -8247,10 +8242,8 @@ package body Sem_Util is
elsif Is_Entity_Name (N) elsif Is_Entity_Name (N)
and then and then
(Ekind (Entity (N)) = E_Discriminant (Ekind (Entity (N)) = E_Discriminant
or else or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter)
((Ekind (Entity (N)) = E_Constant and then Present (Discriminal_Link (Entity (N)))))
or else Ekind (Entity (N)) = E_In_Parameter)
and then Present (Discriminal_Link (Entity (N)))))
then then
return True; return True;
@ -8260,9 +8253,7 @@ package body Sem_Util is
-- For aggregates we have to check that each of the associations -- For aggregates we have to check that each of the associations
-- is preelaborable. -- is preelaborable.
elsif Nkind (N) = N_Aggregate elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
or else Nkind (N) = N_Extension_Aggregate
then
Is_Array_Aggr := Is_Array_Type (Etype (N)); Is_Array_Aggr := Is_Array_Type (Etype (N));
if Is_Array_Aggr then if Is_Array_Aggr then
@ -8564,7 +8555,8 @@ package body Sem_Util is
if No (UT) then if No (UT) then
if No (Full_View (Btype)) then if No (Full_View (Btype)) then
return not Is_Generic_Type (Btype) return not Is_Generic_Type (Btype)
and then not Is_Generic_Type (Root_Type (Btype)); and then
not Is_Generic_Type (Root_Type (Btype));
else else
return not Is_Generic_Type (Root_Type (Full_View (Btype))); return not Is_Generic_Type (Root_Type (Full_View (Btype)));
end if; end if;
@ -8749,9 +8741,7 @@ package body Sem_Util is
Comp : Entity_Id; Comp : Entity_Id;
begin begin
if Is_Private_Type (Typ) if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then
and then Present (Underlying_Type (Typ))
then
return Has_Tagged_Component (Underlying_Type (Typ)); return Has_Tagged_Component (Underlying_Type (Typ));
elsif Is_Array_Type (Typ) then elsif Is_Array_Type (Typ) then
@ -8926,9 +8916,7 @@ package body Sem_Util is
begin begin
S := Current_Scope; S := Current_Scope;
while Present (S) and then S /= Standard_Standard loop while Present (S) and then S /= Standard_Standard loop
if (Ekind (S) = E_Function if Ekind_In (S, E_Function, E_Package, E_Procedure)
or else Ekind (S) = E_Package
or else Ekind (S) = E_Procedure)
and then Is_Generic_Instance (S) and then Is_Generic_Instance (S)
then then
-- A child instance is always compiled in the context of a parent -- A child instance is always compiled in the context of a parent
@ -9479,8 +9467,8 @@ package body Sem_Util is
and then Is_Aliased_View (Renamed_Object (E))))) and then Is_Aliased_View (Renamed_Object (E)))))
or else ((Is_Formal (E) or else ((Is_Formal (E)
or else Ekind (E) = E_Generic_In_Out_Parameter or else Ekind_In (E, E_Generic_In_Out_Parameter,
or else Ekind (E) = E_Generic_In_Parameter) E_Generic_In_Parameter))
and then Is_Tagged_Type (Etype (E))) and then Is_Tagged_Type (Etype (E)))
or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E)) or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E))
@ -9842,9 +9830,9 @@ package body Sem_Util is
begin begin
return Is_Interface (T) return Is_Interface (T)
and then and then
(Is_Protected_Interface (T) (Is_Protected_Interface (T)
or else Is_Synchronized_Interface (T) or else Is_Synchronized_Interface (T)
or else Is_Task_Interface (T)); or else Is_Task_Interface (T));
end Is_Concurrent_Interface; end Is_Concurrent_Interface;
--------------------------- ---------------------------
@ -10282,9 +10270,9 @@ package body Sem_Util is
if not Is_Constrained (Prefix_Type) if not Is_Constrained (Prefix_Type)
and then (not Is_Indefinite_Subtype (Prefix_Type) and then (not Is_Indefinite_Subtype (Prefix_Type)
or else or else
(Is_Generic_Type (Prefix_Type) (Is_Generic_Type (Prefix_Type)
and then Ekind (Current_Scope) = E_Generic_Package and then Ekind (Current_Scope) = E_Generic_Package
and then In_Package_Body (Current_Scope))) and then In_Package_Body (Current_Scope)))
and then (Is_Declared_Within_Variant (Comp) and then (Is_Declared_Within_Variant (Comp)
or else Has_Discriminant_Dependent_Constraint (Comp)) or else Has_Discriminant_Dependent_Constraint (Comp))
@ -10518,11 +10506,17 @@ package body Sem_Util is
function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
begin begin
-- In Ada2012, a scalar type with an aspect Default_Value -- Scalar types
-- is fully initialized.
if Is_Scalar_Type (Typ) then if Is_Scalar_Type (Typ) then
return Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ);
-- A scalar type with an aspect Default_Value is fully initialized
-- Note: Iniitalize/Normalize_Scalars also ensure full initialization
-- of a scalar type, but we don't take that into account here, since
-- we don't want these to affect warnings.
return Has_Default_Aspect (Typ);
elsif Is_Access_Type (Typ) then elsif Is_Access_Type (Typ) then
return True; return True;
@ -11786,7 +11780,10 @@ package body Sem_Util is
Comp_Assn := First (Component_Associations (Orig_N)); Comp_Assn := First (Component_Associations (Orig_N));
while Present (Comp_Assn) loop while Present (Comp_Assn) loop
Expr := Expression (Comp_Assn); Expr := Expression (Comp_Assn);
if Present (Expr) -- needed for box association
-- Note: test for Present here needed for box assocation
if Present (Expr)
and then not Is_SPARK_05_Initialization_Expr (Expr) and then not Is_SPARK_05_Initialization_Expr (Expr)
then then
Is_Ok := False; Is_Ok := False;
@ -11890,7 +11887,8 @@ package body Sem_Util is
return (Is_Tagged_Type (E) return (Is_Tagged_Type (E)
and then (Kind = E_Task_Type and then (Kind = E_Task_Type
or else Kind = E_Protected_Type)) or else
Kind = E_Protected_Type))
or else or else
(Is_Interface (E) (Is_Interface (E)
and then Is_Synchronized_Interface (E)) and then Is_Synchronized_Interface (E))
@ -12215,13 +12213,13 @@ package body Sem_Util is
K : constant Entity_Kind := Ekind (E); K : constant Entity_Kind := Ekind (E);
begin begin
return (K = E_Variable return (K = E_Variable
and then Nkind (Parent (E)) /= N_Exception_Handler) and then Nkind (Parent (E)) /= N_Exception_Handler)
or else (K = E_Component or else (K = E_Component
and then not In_Protected_Function (E)) and then not In_Protected_Function (E))
or else K = E_Out_Parameter or else K = E_Out_Parameter
or else K = E_In_Out_Parameter or else K = E_In_Out_Parameter
or else K = E_Generic_In_Out_Parameter or else K = E_Generic_In_Out_Parameter
-- Current instance of type. If this is a protected type, check -- Current instance of type. If this is a protected type, check
-- we are not within the body of one of its protected functions. -- we are not within the body of one of its protected functions.
@ -12270,10 +12268,10 @@ package body Sem_Util is
return Is_Variable (Expression (Orig_Node)) return Is_Variable (Expression (Orig_Node))
and then and then
(not Comes_From_Source (Orig_Node) (not Comes_From_Source (Orig_Node)
or else or else
(Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node))) (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
and then and then
Is_Tagged_Type (Etype (Expression (Orig_Node))))); Is_Tagged_Type (Etype (Expression (Orig_Node)))));
-- GNAT allows an unchecked type conversion as a variable. This -- GNAT allows an unchecked type conversion as a variable. This
-- only affects the generation of internal expanded code, since -- only affects the generation of internal expanded code, since
@ -13103,9 +13101,9 @@ package body Sem_Util is
end if; end if;
end New_Copy_List_Tree; end New_Copy_List_Tree;
------------------- --------------------------------------------------
-- New_Copy_Tree -- -- New_Copy_Tree Auxiliary Data and Subprograms --
------------------- --------------------------------------------------
use Atree.Unchecked_Access; use Atree.Unchecked_Access;
use Atree_Private_Part; use Atree_Private_Part;
@ -13168,7 +13166,9 @@ package body Sem_Util is
Hash => New_Copy_Hash, Hash => New_Copy_Hash,
Equal => Types."="); Equal => Types."=");
-- Start of processing for New_Copy_Tree function -------------------
-- New_Copy_Tree --
-------------------
function New_Copy_Tree function New_Copy_Tree
(Source : Node_Id; (Source : Node_Id;
@ -14321,9 +14321,9 @@ package body Sem_Util is
then then
if No (Actuals) if No (Actuals)
and then and then
Nkind_In (Parent (N), N_Procedure_Call_Statement, Nkind_In (Parent (N), N_Procedure_Call_Statement,
N_Function_Call, N_Function_Call,
N_Parameter_Association) N_Parameter_Association)
and then Ekind (S) /= E_Function and then Ekind (S) /= E_Function
then then
Set_Etype (N, Etype (S)); Set_Etype (N, Etype (S));
@ -14332,8 +14332,8 @@ package body Sem_Util is
Error_Msg_Name_1 := Chars (S); Error_Msg_Name_1 := Chars (S);
Error_Msg_Sloc := Sloc (S); Error_Msg_Sloc := Sloc (S);
Error_Msg_NE Error_Msg_NE
("missing argument for parameter & " & ("missing argument for parameter & "
"in call to % declared #", N, Formal); & "in call to % declared #", N, Formal);
end if; end if;
elsif Is_Overloadable (S) then elsif Is_Overloadable (S) then
@ -14345,8 +14345,8 @@ package body Sem_Util is
Error_Msg_Sloc := Sloc (Parent (S)); Error_Msg_Sloc := Sloc (Parent (S));
Error_Msg_NE Error_Msg_NE
("missing argument for parameter & " & ("missing argument for parameter & "
"in call to % (inherited) #", N, Formal); & "in call to % (inherited) #", N, Formal);
else else
Error_Msg_NE Error_Msg_NE
@ -14504,8 +14504,7 @@ package body Sem_Util is
-- sure this is a modification. -- sure this is a modification.
if Has_Pragma_Unmodified (Ent) and then Sure then if Has_Pragma_Unmodified (Ent) and then Sure then
Error_Msg_NE Error_Msg_NE ("??pragma Unmodified given for &!", N, Ent);
("??pragma Unmodified given for &!", N, Ent);
end if; end if;
Set_Never_Set_In_Source (Ent, False); Set_Never_Set_In_Source (Ent, False);
@ -15049,7 +15048,7 @@ package body Sem_Util is
-- would cause infinite recursion. -- would cause infinite recursion.
elsif Ekind (Subp) = E_Function elsif Ekind (Subp) = E_Function
and then (Is_Predicate_Function (Subp) and then (Is_Predicate_Function (Subp)
or else or else
Is_Predicate_Function_M (Subp)) Is_Predicate_Function_M (Subp))
then then
@ -15780,11 +15779,7 @@ package body Sem_Util is
if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent))) if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent)))
or else or else
Ekind (Ent) = E_Constant Ekind_In (Ent, E_Constant, E_Out_Parameter, E_In_Out_Parameter)
or else
Ekind (Ent) = E_Out_Parameter
or else
Ekind (Ent) = E_In_Out_Parameter
then then
null; null;
@ -17789,6 +17784,7 @@ package body Sem_Util is
Op : constant Node_Id := Right_Opnd (Parent (Expr)); Op : constant Node_Id := Right_Opnd (Parent (Expr));
L : constant Node_Id := Left_Opnd (Op); L : constant Node_Id := Left_Opnd (Op);
R : constant Node_Id := Right_Opnd (Op); R : constant Node_Id := Right_Opnd (Op);
begin begin
-- The case for the message is when the left operand of the -- The case for the message is when the left operand of the
-- comparison is the same modular type, or when it is an -- comparison is the same modular type, or when it is an

5
gcc/ada/sinfo.ads
View File

@ -4246,6 +4246,11 @@ package Sinfo is
-- point operands if the Treat_Fixed_As_Integer flag is set and will -- point operands if the Treat_Fixed_As_Integer flag is set and will
-- thus treat these nodes in identical manner, ignoring small values. -- thus treat these nodes in identical manner, ignoring small values.
-- Note on equality/inequality tests for records. In the expanded tree,
-- record comparisons are always expanded to be a series of component
-- comparisons, so the back end will never see an equality or inequality
-- operation with operands of a record type.
-- Note on overflow handling: When the overflow checking mode is set to -- Note on overflow handling: When the overflow checking mode is set to
-- MINIMIZED or ELIMINATED, nodes for signed arithmetic operations may -- MINIMIZED or ELIMINATED, nodes for signed arithmetic operations may
-- be modified to use a larger type for the operands and result. In -- be modified to use a larger type for the operands and result. In