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

[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>
* 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;
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
-- 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)::
* System.Address_Image (s-addima.ads)::
* System.Assertions (s-assert.ads)::
* System.Atomic_Counters (s-atocou.ads)::
* System.Memory (s-memory.ads)::
* System.Multiprocessors (s-multip.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)::
* System.Address_Image (s-addima.ads)::
* System.Assertions (s-assert.ads)::
* System.Atomic_Counters (s-atocou.ads)::
* System.Memory (s-memory.ads)::
* System.Multiprocessors (s-multip.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
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)
@section @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-atocou", F), -- System.Atomic_Counters
("s-assert", F), -- System.Assertions
("s-diflio", F), -- System.Dim.Float_IO
("s-diinio", F), -- System.Dim.Integer_IO

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

@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -37,8 +37,6 @@
-- - all x86 platforms
-- - all x86_64 platforms
-- Why isn't this package available to application programs???
package System.Atomic_Counters is
pragma Preelaborate;
@ -59,20 +57,19 @@ package System.Atomic_Counters is
function Decrement (Item : in out Atomic_Counter) return Boolean;
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;
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);
pragma Inline_Always (Initialize);
-- 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.
private
type Unsigned_32 is mod 2 ** 32;
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
-- modulus values. Arithmetic is done in Long_Long_Unsigned, with explicit
-- 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;
package System.Exp_Mod is
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
(Left : 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;

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

@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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
Start : Positive;
-- Saves location of first non-blank (not used in this case)
-- Saves location of first non-blank
begin
Scan_Sign (Str, Ptr, Max, Minus, Start);

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

@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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);
-- 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
-- character of S. Any lower case characters present in S will be folded
-- to their upper case equivalent except for character literals. If S
-- consists of entirely blanks then Constraint_Error is raised.
-- character of S. Any lower case characters present in S will be folded to
-- their upper case equivalent except for character literals. If S consists
-- 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
@ -60,25 +60,25 @@ package System.Val_Util is
-- last character in the string). Scan_Sign first scans out any initial
-- 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
-- character to follow (Constraint_Error is raised if plus or minus
-- appears at the end of the string or with a following blank). Minus is
-- set True if a minus sign was skipped, and False otherwise. On exit
-- Ptr.all points to the character after the sign, or to the first
-- non-blank character if no sign is present. Start is set to the point
-- to the first non-blank character (sign or digit after it).
-- character to follow (Constraint_Error is raised if plus or minus appears
-- at the end of the string or with a following blank). Minus is set True
-- if a minus sign was skipped, and False otherwise. On exit Ptr.all points
-- to the character after the sign, or to the first non-blank character
-- if no sign is present. Start is set to the point to the first non-blank
-- character (sign or digit after it).
--
-- 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
-- is greater than Max as required in this case. Constraint_Error is
-- also raised in this case.
-- is greater than Max as required in this case. Constraint_Error is also
-- raised in this case.
procedure Scan_Plus_Sign
(Str : String;
Ptr : not null access Integer;
Max : Integer;
Start : out Positive);
-- Same as Scan_Sign, but allows only plus, not minus.
-- This is used for modular types.
-- Same as Scan_Sign, but allows only plus, not minus. This is used for
-- modular types.
function Scan_Exponent
(Str : String;

38
gcc/ada/sem_ch12.adb
View file

@ -1056,7 +1056,12 @@ package body Sem_Ch12 is
Actuals := 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;
while Present (F) loop
@ -1066,16 +1071,26 @@ package body Sem_Ch12 is
New_F := Make_Temporary
(Loc, Character'Val (Character'Pos ('A') + N_Parms));
-- If a formal has a class-wide type, rewrite as the corresponding
-- attribute, because the class-wide type is not retrievable by
-- visbility.
if No (Actual) then
-- 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
Parm_Type := New_Occurrence_Of (Etype (F), Loc);
end if;
@ -1766,8 +1781,7 @@ package body Sem_Ch12 is
else
if GNATprove_Mode
and then
Present
and then Present
(Containing_Package_With_Ext_Axioms
(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;
end if;
-- Contract items related to subprogram bodies. The applicable pragmas
-- are:
-- Contract items related to subprogram bodies. Applicable pragmas are:
-- Refined_Depends
-- Refined_Global
-- Refined_Post
@ -392,7 +391,7 @@ package body Sem_Util is
raise Program_Error;
end if;
-- Contract items related to variables. The applicable pragmas are:
-- Contract items related to variables. Applicable pragmas are:
-- Async_Readers
-- Async_Writers
-- Effective_Reads
@ -801,9 +800,7 @@ package body Sem_Util is
return;
end if;
if Is_Generic_Formal (Typ)
and then Is_Discrete_Type (Typ)
then
if Is_Generic_Formal (Typ) and then Is_Discrete_Type (Typ) then
Set_No_Predicate_On_Actual (Typ);
end if;
@ -1442,8 +1439,7 @@ package body Sem_Util is
pragma Assert (Has_Default_Init_Cond (Typ));
pragma Assert (Present (Prag));
-- Nothing to do if the default initial condition procedure was already
-- built.
-- Nothing to do if default initial condition procedure already built
if Present (Default_Init_Cond_Procedure (Typ)) then
return;
@ -1909,7 +1905,7 @@ package body Sem_Util is
return False;
else
return
Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
and then
Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
end if;
@ -1938,7 +1934,7 @@ package body Sem_Util is
return False;
else
return
Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
and then
Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
end if;
@ -1992,6 +1988,7 @@ package body Sem_Util is
and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
then
-- The non-limited view is fully declared
null;
else
@ -2429,7 +2426,7 @@ package body Sem_Util is
elsif Nkind_In (Choice, N_Range,
N_Subtype_Indication)
or else (Is_Entity_Name (Choice)
and then Is_Type (Entity (Choice)))
and then Is_Type (Entity (Choice)))
then
declare
L, H : Node_Id;
@ -3049,7 +3046,8 @@ package body Sem_Util is
Comes_From_Source (N)
and then Is_Entity_Name (N)
and then (Entity (N) = Standard_True
or else Entity (N) = Standard_False);
or else
Entity (N) = Standard_False);
end Is_Trivial_Boolean;
-------------------------
@ -4747,7 +4745,8 @@ package body Sem_Util is
-- attempt to detect partial overlap of slices.
return Denotes_Same_Object (Lo1, Lo2)
and then Denotes_Same_Object (Hi1, Hi2);
and then
Denotes_Same_Object (Hi1, Hi2);
end;
-- 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)
then
declare
Root1, Root2 : Node_Id;
Root1, Root2 : Node_Id;
Depth1, Depth2 : Int := 0;
begin
@ -4807,8 +4806,8 @@ package body Sem_Util is
Root2 := Prefix (A2);
while not Is_Entity_Name (Root2) loop
if not Nkind_In
(Root2, N_Selected_Component, N_Indexed_Component)
if not Nkind_In (Root2, N_Selected_Component,
N_Indexed_Component)
then
return False;
else
@ -4826,7 +4825,7 @@ package body Sem_Util is
elsif Depth1 > Depth2 then
Root1 := Prefix (A1);
for I in 1 .. Depth1 - Depth2 - 1 loop
for J in 1 .. Depth1 - Depth2 - 1 loop
Root1 := Prefix (Root1);
end loop;
@ -4834,7 +4833,7 @@ package body Sem_Util is
else
Root2 := Prefix (A2);
for I in 1 .. Depth2 - Depth1 - 1 loop
for J in 1 .. Depth2 - Depth1 - 1 loop
Root2 := Prefix (Root2);
end loop;
@ -4897,7 +4896,6 @@ package body Sem_Util is
begin
if Nkind (N) = N_Defining_Program_Unit_Name then
return Name (N);
else
return Prefix (N);
end if;
@ -4911,7 +4909,6 @@ package body Sem_Util is
begin
if Nkind (N) = N_Defining_Program_Unit_Name then
return Defining_Identifier (N);
else
return Selector_Name (N);
end if;
@ -6552,9 +6549,8 @@ package body Sem_Util is
if In_Spec_Expression then
return Typ;
elsif Is_Private_Type (Typ)
and then not Has_Discriminants (Typ)
then
elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then
-- If the type has no discriminants, there is no subtype to
-- 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
-- we simply iterate through the chain of literal until the one
-- with the desired position value is found.
--
else
if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
@ -7579,7 +7574,7 @@ package body Sem_Util is
elsif Default /= Unknown
and then (Has_Size_Clause (Etype (Expr))
or else
or else
Has_Alignment_Clause (Etype (Expr)))
then
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
-- 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;
elsif Property = Name_Async_Writers and then Is_Enabled (AW) then
elsif Property = Name_Async_Writers and then Is_Enabled (AW) then
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;
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
return Has_No_Obvious_Side_Effects (Left_Opnd (N))
and then
and then
Has_No_Obvious_Side_Effects (Right_Opnd (N));
elsif Nkind (N) = N_Expression_With_Actions
@ -8247,10 +8242,8 @@ package body Sem_Util is
elsif Is_Entity_Name (N)
and then
(Ekind (Entity (N)) = E_Discriminant
or else
((Ekind (Entity (N)) = E_Constant
or else Ekind (Entity (N)) = E_In_Parameter)
and then Present (Discriminal_Link (Entity (N)))))
or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter)
and then Present (Discriminal_Link (Entity (N)))))
then
return True;
@ -8260,9 +8253,7 @@ package body Sem_Util is
-- For aggregates we have to check that each of the associations
-- is preelaborable.
elsif Nkind (N) = N_Aggregate
or else Nkind (N) = N_Extension_Aggregate
then
elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
Is_Array_Aggr := Is_Array_Type (Etype (N));
if Is_Array_Aggr then
@ -8564,7 +8555,8 @@ package body Sem_Util is
if No (UT) then
if No (Full_View (Btype)) then
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
return not Is_Generic_Type (Root_Type (Full_View (Btype)));
end if;
@ -8749,9 +8741,7 @@ package body Sem_Util is
Comp : Entity_Id;
begin
if Is_Private_Type (Typ)
and then Present (Underlying_Type (Typ))
then
if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then
return Has_Tagged_Component (Underlying_Type (Typ));
elsif Is_Array_Type (Typ) then
@ -8926,9 +8916,7 @@ package body Sem_Util is
begin
S := Current_Scope;
while Present (S) and then S /= Standard_Standard loop
if (Ekind (S) = E_Function
or else Ekind (S) = E_Package
or else Ekind (S) = E_Procedure)
if Ekind_In (S, E_Function, E_Package, E_Procedure)
and then Is_Generic_Instance (S)
then
-- 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)))))
or else ((Is_Formal (E)
or else Ekind (E) = E_Generic_In_Out_Parameter
or else Ekind (E) = E_Generic_In_Parameter)
or else Ekind_In (E, E_Generic_In_Out_Parameter,
E_Generic_In_Parameter))
and then Is_Tagged_Type (Etype (E)))
or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E))
@ -9842,9 +9830,9 @@ package body Sem_Util is
begin
return Is_Interface (T)
and then
(Is_Protected_Interface (T)
or else Is_Synchronized_Interface (T)
or else Is_Task_Interface (T));
(Is_Protected_Interface (T)
or else Is_Synchronized_Interface (T)
or else Is_Task_Interface (T));
end Is_Concurrent_Interface;
---------------------------
@ -10282,9 +10270,9 @@ package body Sem_Util is
if not Is_Constrained (Prefix_Type)
and then (not Is_Indefinite_Subtype (Prefix_Type)
or else
(Is_Generic_Type (Prefix_Type)
and then Ekind (Current_Scope) = E_Generic_Package
and then In_Package_Body (Current_Scope)))
(Is_Generic_Type (Prefix_Type)
and then Ekind (Current_Scope) = E_Generic_Package
and then In_Package_Body (Current_Scope)))
and then (Is_Declared_Within_Variant (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
begin
-- In Ada2012, a scalar type with an aspect Default_Value
-- is fully initialized.
-- Scalar types
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
return True;
@ -11786,7 +11780,10 @@ package body Sem_Util is
Comp_Assn := First (Component_Associations (Orig_N));
while Present (Comp_Assn) loop
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)
then
Is_Ok := False;
@ -11890,7 +11887,8 @@ package body Sem_Util is
return (Is_Tagged_Type (E)
and then (Kind = E_Task_Type
or else Kind = E_Protected_Type))
or else
Kind = E_Protected_Type))
or else
(Is_Interface (E)
and then Is_Synchronized_Interface (E))
@ -12215,13 +12213,13 @@ package body Sem_Util is
K : constant Entity_Kind := Ekind (E);
begin
return (K = E_Variable
and then Nkind (Parent (E)) /= N_Exception_Handler)
or else (K = E_Component
and then not In_Protected_Function (E))
or else K = E_Out_Parameter
or else K = E_In_Out_Parameter
or else K = E_Generic_In_Out_Parameter
return (K = E_Variable
and then Nkind (Parent (E)) /= N_Exception_Handler)
or else (K = E_Component
and then not In_Protected_Function (E))
or else K = E_Out_Parameter
or else K = E_In_Out_Parameter
or else K = E_Generic_In_Out_Parameter
-- Current instance of type. If this is a protected type, check
-- 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))
and then
(not Comes_From_Source (Orig_Node)
or else
(Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
and then
Is_Tagged_Type (Etype (Expression (Orig_Node)))));
or else
(Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
and then
Is_Tagged_Type (Etype (Expression (Orig_Node)))));
-- GNAT allows an unchecked type conversion as a variable. This
-- only affects the generation of internal expanded code, since
@ -13103,9 +13101,9 @@ package body Sem_Util is
end if;
end New_Copy_List_Tree;
-------------------
-- New_Copy_Tree --
-------------------
--------------------------------------------------
-- New_Copy_Tree Auxiliary Data and Subprograms --
--------------------------------------------------
use Atree.Unchecked_Access;
use Atree_Private_Part;
@ -13168,7 +13166,9 @@ package body Sem_Util is
Hash => New_Copy_Hash,
Equal => Types."=");
-- Start of processing for New_Copy_Tree function
-------------------
-- New_Copy_Tree --
-------------------
function New_Copy_Tree
(Source : Node_Id;
@ -14321,9 +14321,9 @@ package body Sem_Util is
then
if No (Actuals)
and then
Nkind_In (Parent (N), N_Procedure_Call_Statement,
N_Function_Call,
N_Parameter_Association)
Nkind_In (Parent (N), N_Procedure_Call_Statement,
N_Function_Call,
N_Parameter_Association)
and then Ekind (S) /= E_Function
then
Set_Etype (N, Etype (S));
@ -14332,8 +14332,8 @@ package body Sem_Util is
Error_Msg_Name_1 := Chars (S);
Error_Msg_Sloc := Sloc (S);
Error_Msg_NE
("missing argument for parameter & " &
"in call to % declared #", N, Formal);
("missing argument for parameter & "
& "in call to % declared #", N, Formal);
end if;
elsif Is_Overloadable (S) then
@ -14345,8 +14345,8 @@ package body Sem_Util is
Error_Msg_Sloc := Sloc (Parent (S));
Error_Msg_NE
("missing argument for parameter & " &
"in call to % (inherited) #", N, Formal);
("missing argument for parameter & "
& "in call to % (inherited) #", N, Formal);
else
Error_Msg_NE
@ -14504,8 +14504,7 @@ package body Sem_Util is
-- sure this is a modification.
if Has_Pragma_Unmodified (Ent) and then Sure then
Error_Msg_NE
("??pragma Unmodified given for &!", N, Ent);
Error_Msg_NE ("??pragma Unmodified given for &!", N, Ent);
end if;
Set_Never_Set_In_Source (Ent, False);
@ -15049,7 +15048,7 @@ package body Sem_Util is
-- would cause infinite recursion.
elsif Ekind (Subp) = E_Function
and then (Is_Predicate_Function (Subp)
and then (Is_Predicate_Function (Subp)
or else
Is_Predicate_Function_M (Subp))
then
@ -15780,11 +15779,7 @@ package body Sem_Util is
if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent)))
or else
Ekind (Ent) = E_Constant
or else
Ekind (Ent) = E_Out_Parameter
or else
Ekind (Ent) = E_In_Out_Parameter
Ekind_In (Ent, E_Constant, E_Out_Parameter, E_In_Out_Parameter)
then
null;
@ -17789,6 +17784,7 @@ package body Sem_Util is
Op : constant Node_Id := Right_Opnd (Parent (Expr));
L : constant Node_Id := Left_Opnd (Op);
R : constant Node_Id := Right_Opnd (Op);
begin
-- The case for the message is when the left operand of the
-- 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
-- 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
-- MINIMIZED or ELIMINATED, nodes for signed arithmetic operations may
-- be modified to use a larger type for the operands and result. In