aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--gcc/ada/ChangeLog73
-rw-r--r--gcc/ada/checks.adb18
-rw-r--r--gcc/ada/exp_attr.adb80
-rw-r--r--gcc/ada/exp_imgv.adb19
-rw-r--r--gcc/ada/freeze.adb4
-rw-r--r--gcc/ada/layout.adb102
-rw-r--r--gcc/ada/par-ch4.adb5
-rw-r--r--gcc/ada/s-atocou-builtin.adb14
-rw-r--r--gcc/ada/s-finmas.adb6
-rw-r--r--gcc/ada/s-taprop-linux.adb17
-rw-r--r--gcc/ada/s-taprop-vms.adb2
-rw-r--r--gcc/ada/sem_ch3.adb22
-rw-r--r--gcc/ada/sem_res.adb5
-rw-r--r--gcc/ada/sem_util.adb15
-rw-r--r--gcc/ada/sinput.ads14
15 files changed, 337 insertions, 59 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index b98c7db..d1aad1ded 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,78 @@
2011-11-21 Robert Dewar <dewar@adacore.com>
+ * sinput.ads: Minor comment fix.
+
+2011-11-21 Robert Dewar <dewar@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference, case First_Bit,
+ Last_Bit, Position): Handle 2005 case.
+
+2011-11-21 Robert Dewar <dewar@adacore.com>
+
+ * s-atocou-builtin.adb (Decrement): Use Unrestricted_Access
+ to deal with fact that we properly detect the error if Access
+ is used.
+ (Increment): Same fix.
+ * s-taprop-linux.adb (Create_Task): Use Unrestricted_Access
+ to deal with fact that we properly detect the error if Access
+ is used.
+ * sem_util.adb (Is_Volatile_Object): Properly record that A.B is
+ volatile if the B component is volatile. This affects the check
+ for passing such a by reference volatile actual to a non-volatile
+ formal (which should be illegal)
+
+2011-11-21 Robert Dewar <dewar@adacore.com>
+
+ * freeze.adb (Freeze_Enumeration_Type): Make sure to set both
+ size and alignment for foreign convention enumeration types.
+ * layout.adb (Set_Elem_Alignment): Redo setting of alignment
+ when size is set.
+
+2011-11-21 Yannick Moy <moy@adacore.com>
+
+ * checks.adb (Apply_Access_Check, Apply_Arithmetic_Overflow_Check,
+ Apply_Discriminant_Check, Apply_Divide_Check,
+ Apply_Selected_Length_Checks, Apply_Selected_Range_Checks,
+ Build_Discriminant_Checks, Insert_Range_Checks, Selected_Length_Checks,
+ Selected_Range_Checks): Replace reference to Expander_Active
+ with reference to Full_Expander_Active, so that expansion of
+ checks is not performed in Alfa mode
+
+2011-11-21 Tristan Gingold <gingold@adacore.com>
+
+ * s-taprop-vms.adb (Create_Task): Use Unrestricted_Access to deal with
+ fact that we properly detect the error if Access is used.
+
+2011-11-21 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * par-ch4.adb (P_Quantified_Expression): Add an Ada 2012 check.
+
+2011-11-21 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_imgv.adb: Add with and use clause for Errout.
+ (Expand_Width_Attribute): Emit a warning when in
+ configurable run-time mode to provide a better diagnostic message.
+
+2011-11-21 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * s-finmas.adb (Finalize): Add comment concerning double finalization.
+
+2011-11-21 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Access_Definition): If the access definition
+ is itself the return type of an access to function definition
+ which is ultimately the return type of an access to subprogram
+ declaration, its scope is the enclosing scope of the ultimate
+ access to subprogram.
+
+2011-11-21 Steve Baird <baird@adacore.com>
+
+ * sem_res.adb (Valid_Conversion): If a conversion was legal
+ in the body of a generic, then the corresponding conversion is
+ legal in the expanded body of an instance of the generic.
+
+2011-11-21 Robert Dewar <dewar@adacore.com>
+
* sem_ch3.adb: Minor reformatting.
2011-11-21 Robert Dewar <dewar@adacore.com>
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index e6d8bf9..01f240f 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -442,7 +442,7 @@ package body Checks is
-- are cases (e.g. with pragma Debug) where generating the checks
-- can cause real trouble).
- if not Expander_Active then
+ if not Full_Expander_Active then
return;
end if;
@@ -878,7 +878,7 @@ package body Checks is
if Backend_Overflow_Checks_On_Target
or else not Do_Overflow_Check (N)
- or else not Expander_Active
+ or else not Full_Expander_Active
or else (Present (Parent (N))
and then Nkind (Parent (N)) = N_Type_Conversion
and then Integer_Promotion_Possible (Parent (N)))
@@ -1178,7 +1178,7 @@ package body Checks is
-- Nothing to do if discriminant checks are suppressed or else no code
-- is to be generated
- if not Expander_Active
+ if not Full_Expander_Active
or else Discriminant_Checks_Suppressed (T_Typ)
then
return;
@@ -1462,7 +1462,7 @@ package body Checks is
-- Don't actually use this value
begin
- if Expander_Active
+ if Full_Expander_Active
and then not Backend_Divide_Checks_On_Target
and then Check_Needed (Right, Division_Check)
then
@@ -2118,7 +2118,7 @@ package body Checks is
(not Length_Checks_Suppressed (Target_Typ));
begin
- if not Expander_Active then
+ if not Full_Expander_Active then
return;
end if;
@@ -2226,7 +2226,7 @@ package body Checks is
(not Range_Checks_Suppressed (Target_Typ));
begin
- if not Expander_Active or else not Checks_On then
+ if not Full_Expander_Active or else not Checks_On then
return;
end if;
@@ -5309,7 +5309,7 @@ package body Checks is
-- enhanced to check for an always True value in the condition and to
-- generate a compilation warning???
- if not Expander_Active or else not Checks_On then
+ if not Full_Expander_Active or else not Checks_On then
return;
end if;
@@ -6236,7 +6236,7 @@ package body Checks is
-- Start of processing for Selected_Length_Checks
begin
- if not Expander_Active then
+ if not Full_Expander_Active then
return Ret_Result;
end if;
@@ -6810,7 +6810,7 @@ package body Checks is
-- Start of processing for Selected_Range_Checks
begin
- if not Expander_Active then
+ if not Full_Expander_Active then
return Ret_Result;
end if;
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 57e94d2..1883d36 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -2117,21 +2117,38 @@ package body Exp_Attr is
-- computation to be completed in the back-end, since we don't know what
-- layout will be chosen.
- when Attribute_First_Bit => First_Bit : declare
+ when Attribute_First_Bit => First_Bit_Attr : declare
CE : constant Entity_Id := Entity (Selector_Name (Pref));
begin
- if Known_Static_Component_Bit_Offset (CE) then
+ -- In Ada 2005 (or later) if we have the standard nondefault
+ -- bit order, then we return the original value as given in
+ -- the component clause (RM 2005 13.5.2(3/2)).
+
+ if Present (Component_Clause (CE))
+ and then Ada_Version >= Ada_2005
+ and then not Reverse_Bit_Order (Scope (CE))
+ then
Rewrite (N,
Make_Integer_Literal (Loc,
- Component_Bit_Offset (CE) mod System_Storage_Unit));
+ Intval => Expr_Value (First_Bit (Component_Clause (CE)))));
+ Analyze_And_Resolve (N, Typ);
+ -- Otherwise (Ada 83/95 or Ada 2005 or later with reverse bit order),
+ -- rewrite with normalized value if we know it statically.
+
+ elsif Known_Static_Component_Bit_Offset (CE) then
+ Rewrite (N,
+ Make_Integer_Literal (Loc,
+ Component_Bit_Offset (CE) mod System_Storage_Unit));
Analyze_And_Resolve (N, Typ);
+ -- Otherwise left to back end, just do universal integer checks
+
else
Apply_Universal_Integer_Attribute_Checks (N);
end if;
- end First_Bit;
+ end First_Bit_Attr;
-----------------
-- Fixed_Value --
@@ -2680,24 +2697,41 @@ package body Exp_Attr is
-- the computation up to the back end, since we don't know what layout
-- will be chosen.
- when Attribute_Last_Bit => Last_Bit : declare
+ when Attribute_Last_Bit => Last_Bit_Attr : declare
CE : constant Entity_Id := Entity (Selector_Name (Pref));
begin
- if Known_Static_Component_Bit_Offset (CE)
+ -- In Ada 2005 (or later) if we have the standard nondefault
+ -- bit order, then we return the original value as given in
+ -- the component clause (RM 2005 13.5.2(4/2)).
+
+ if Present (Component_Clause (CE))
+ and then Ada_Version >= Ada_2005
+ and then not Reverse_Bit_Order (Scope (CE))
+ then
+ Rewrite (N,
+ Make_Integer_Literal (Loc,
+ Intval => Expr_Value (Last_Bit (Component_Clause (CE)))));
+ Analyze_And_Resolve (N, Typ);
+
+ -- Otherwise (Ada 83/95 or Ada 2005 or later with reverse bit order),
+ -- rewrite with normalized value if we know it statically.
+
+ elsif Known_Static_Component_Bit_Offset (CE)
and then Known_Static_Esize (CE)
then
Rewrite (N,
Make_Integer_Literal (Loc,
Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit)
+ Esize (CE) - 1));
-
Analyze_And_Resolve (N, Typ);
+ -- Otherwise leave to back end, just apply universal integer checks
+
else
Apply_Universal_Integer_Attribute_Checks (N);
end if;
- end Last_Bit;
+ end Last_Bit_Attr;
------------------
-- Leading_Part --
@@ -3495,21 +3529,41 @@ package body Exp_Attr is
-- the computation up to the back end, since we don't know what layout
-- will be chosen.
- when Attribute_Position => Position :
+ when Attribute_Position => Position_Attr :
declare
CE : constant Entity_Id := Entity (Selector_Name (Pref));
begin
if Present (Component_Clause (CE)) then
- Rewrite (N,
- Make_Integer_Literal (Loc,
- Intval => Component_Bit_Offset (CE) / System_Storage_Unit));
+
+ -- In Ada 2005 (or later) if we have the standard nondefault
+ -- bit order, then we return the original value as given in
+ -- the component clause (RM 2005 13.5.2(2/2)).
+
+ if Ada_Version >= Ada_2005
+ and then not Reverse_Bit_Order (Scope (CE))
+ then
+ Rewrite (N,
+ Make_Integer_Literal (Loc,
+ Intval => Expr_Value (Position (Component_Clause (CE)))));
+
+ -- Otherwise (Ada 83 or 95, or reverse bit order specified in
+ -- later Ada version), return the normalized value.
+
+ else
+ Rewrite (N,
+ Make_Integer_Literal (Loc,
+ Intval => Component_Bit_Offset (CE) / System_Storage_Unit));
+ end if;
+
Analyze_And_Resolve (N, Typ);
+ -- If back end is doing things, just apply universal integer checks
+
else
Apply_Universal_Integer_Attribute_Checks (N);
end if;
- end Position;
+ end Position_Attr;
----------
-- Pred --
diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb
index 78d9b00..d66824b 100644
--- a/gcc/ada/exp_imgv.adb
+++ b/gcc/ada/exp_imgv.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2011, 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- --
@@ -27,6 +27,7 @@ with Atree; use Atree;
with Casing; use Casing;
with Checks; use Checks;
with Einfo; use Einfo;
+with Errout; use Errout;
with Exp_Util; use Exp_Util;
with Lib; use Lib;
with Namet; use Namet;
@@ -1065,10 +1066,10 @@ package body Exp_Imgv is
Pref : constant Node_Id := Prefix (N);
Ptyp : constant Entity_Id := Etype (Pref);
Rtyp : constant Entity_Id := Root_Type (Ptyp);
- XX : RE_Id;
- YY : Entity_Id;
Arglist : List_Id;
Ttyp : Entity_Id;
+ XX : RE_Id;
+ YY : Entity_Id;
begin
-- Types derived from Standard.Boolean
@@ -1157,6 +1158,18 @@ package body Exp_Imgv is
if Discard_Names (Rtyp) then
+ -- Emit a detailed warning in configurable run-time mode because
+ -- loading RE_Null does not give a precise indication of the real
+ -- issue.
+
+ if Configurable_Run_Time_Mode
+ and then not Has_Warnings_Off (Rtyp)
+ then
+ Error_Msg_Name_1 := Attribute_Name (N);
+ Error_Msg_N ("?attribute % not supported in configurable " &
+ "run-time mode", N);
+ end if;
+
-- This is a configurable run-time, or else a restriction is in
-- effect. In either case the attribute cannot be supported. Force
-- a load error from Rtsfind to generate an appropriate message,
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index b1a33d5..d975984 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -4239,7 +4239,8 @@ package body Freeze is
-- By default, if no size clause is present, an enumeration type with
-- Convention C is assumed to interface to a C enum, and has integer
-- size. This applies to types. For subtypes, verify that its base
- -- type has no size clause either.
+ -- type has no size clause either. Treat other foreign conventions
+ -- in the same way, and also make sure alignment is set right.
if Has_Foreign_Convention (Typ)
and then not Has_Size_Clause (Typ)
@@ -4247,6 +4248,7 @@ package body Freeze is
and then Esize (Typ) < Standard_Integer_Size
then
Init_Esize (Typ, Standard_Integer_Size);
+ Set_Alignment (Typ, Alignment (Standard_Integer));
else
-- If the enumeration type interfaces to C, and it has a size clause
diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb
index bb8aa11..519fad0 100644
--- a/gcc/ada/layout.adb
+++ b/gcc/ada/layout.adb
@@ -3088,7 +3088,7 @@ package body Layout is
end if;
-- Here we calculate the alignment as the largest power of two multiple
- -- of System.Storage_Unit that does not exceed either the actual size of
+ -- of System.Storage_Unit that does not exceed either the object size of
-- the type, or the maximum allowed alignment.
declare
@@ -3126,21 +3126,101 @@ package body Layout is
A := 2 * A;
end loop;
- -- Now we think we should set the alignment to A, but we skip this if
- -- an alignment is already set to a value greater than A (happens for
- -- derived types).
+ -- If alignment is currently not set, then we can safetly set it to
+ -- this new calculated value.
- -- However, if the alignment is known and too small it must be
- -- increased, this happens in a case like:
+ if Unknown_Alignment (E) then
+ Init_Alignment (E, A);
+
+ -- Cases where we have inherited an alignment
+
+ -- For constructed types, always reset the alignment, these are
+ -- Generally invisible to the user anyway, and that way we are
+ -- sure that no constructed types have weird alignments.
+
+ elsif not Comes_From_Source (E) then
+ Init_Alignment (E, A);
+
+ -- If this inherited alignment is the same as the one we computed,
+ -- then obviously everything is fine, and we do not need to reset it.
- -- type R is new Character;
- -- for R'Size use 16;
+ elsif Alignment (E) = A then
+ null;
- -- Here the alignment inherited from Character is 1, but it must be
- -- increased to 2 to reflect the increased size.
+ -- Now we come to the difficult cases where we have inherited an
+ -- alignment and size, but overridden the size but not the alignment.
+
+ elsif Has_Size_Clause (E) or else Has_Object_Size_Clause (E) then
+
+ -- This is tricky, it might be thought that we should try to
+ -- inherit the alignment, since that's what the RM implies, but
+ -- that leads to complex rules and oddities. Consider for example:
+
+ -- type R is new Character;
+ -- for R'Size use 16;
+
+ -- It seems quite bogus in this case to inherit an alignment of 1
+ -- from the parent type Character. Furthermore, if that's what the
+ -- programmer really wanted for some odd reason, then they could
+ -- specify the alignment they wanted.
+
+ -- Furthermore we really don't want to inherit the alignment in
+ -- the case of a specified Object_Size for a subtype, since then
+ -- there would be no way of overriding to give a reasonable value
+ -- (we don't have an Object_Subtype attribute). Consider:
+
+ -- subtype R is new Character;
+ -- for R'Object_Size use 16;
+
+ -- If we inherit the alignment of 1, then we have an odd
+ -- inefficient alignment for the subtype, which cannot be fixed.
+
+ -- So we make the decision that if Size (or Object_Size) is given
+ -- (and, in the case of a first subtype, the alignment is not set
+ -- with a specific alignment clause). We reset the alignment to
+ -- the appropriate value for the specified size. This is a nice
+ -- simple rule to implement and document.
+
+ -- There is one slight glitch, which is that a confirming size
+ -- clause can now change the alignment, which, if we really think
+ -- that confirming rep clauses should have no effect, is a no-no.
+
+ -- type R is new Character;
+ -- for R'Alignment use 2;
+ -- type S is new R;
+ -- for S'Size use Character'Size;
+
+ -- Now the alignment of S is 1 instead of 2, as a result of
+ -- applying the above rule to the confirming rep clause for S. Not
+ -- clear this is worth worrying about. If we recorded whether a
+ -- size clause was confirming we could avoid this, but right now
+ -- we have no way of doing that or easily figuring it out, so we
+ -- don't bother.
+
+ -- Historical note. In versions of GNAT prior to Nov 6th, 2010, an
+ -- odd distinction was made between inherited alignments greater
+ -- than the computed alignment (where the larger alignment was
+ -- inherited) and inherited alignments smaller than the computed
+ -- alignment (where the smaller alignment was overridden). This
+ -- was a dubious fix to get around an ACATS problem which seems
+ -- to have disappeared anyway, and in any case, this peculiarity
+ -- was never documented.
- if Unknown_Alignment (E) or else Alignment (E) < A then
Init_Alignment (E, A);
+
+ -- If no Size (or Object_Size) was specified, then we inherited the
+ -- object size, so we should inherit the alignment as well and not
+ -- modify it. This takes care of cases like:
+
+ -- type R is new Integer;
+ -- for R'Alignment use 1;
+ -- subtype S is R;
+
+ -- Here we have R has a default Object_Size of 32, and a specified
+ -- alignment of 1, and it seeems right for S to inherit both values.
+
+ else
+ null;
end if;
end;
end Set_Elem_Alignment;
diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb
index 85b4024..59884d2 100644
--- a/gcc/ada/par-ch4.adb
+++ b/gcc/ada/par-ch4.adb
@@ -2553,6 +2553,11 @@ package body Ch4 is
Node1 : Node_Id;
begin
+ if Ada_Version < Ada_2012 then
+ Error_Msg_SC ("quantified expression is an Ada 2012 feature");
+ Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch");
+ end if;
+
Scan; -- past FOR
Node1 := New_Node (N_Quantified_Expression, Prev_Token_Ptr);
diff --git a/gcc/ada/s-atocou-builtin.adb b/gcc/ada/s-atocou-builtin.adb
index 8ec851e..f230721 100644
--- a/gcc/ada/s-atocou-builtin.adb
+++ b/gcc/ada/s-atocou-builtin.adb
@@ -50,7 +50,12 @@ package body System.Atomic_Counters is
function Decrement (Item : in out Atomic_Counter) return Boolean is
begin
- return Sync_Sub_And_Fetch (Item.Value'Access, 1) = 0;
+ -- 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.
+
+ return Sync_Sub_And_Fetch (Item.Value'Unrestricted_Access, 1) = 0;
end Decrement;
---------------
@@ -59,7 +64,12 @@ package body System.Atomic_Counters is
procedure Increment (Item : in out Atomic_Counter) is
begin
- Sync_Add_And_Fetch (Item.Value'Access, 1);
+ -- 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.
+
+ Sync_Add_And_Fetch (Item.Value'Unrestricted_Access, 1);
end Increment;
------------
diff --git a/gcc/ada/s-finmas.adb b/gcc/ada/s-finmas.adb
index 8474ff4..918519b 100644
--- a/gcc/ada/s-finmas.adb
+++ b/gcc/ada/s-finmas.adb
@@ -181,6 +181,12 @@ package body System.Finalization_Masters is
if Master.Finalization_Started then
Unlock_Task.all;
+
+ -- Double finalization may occur during the handling of stand alone
+ -- libraries or the finalization of a pool with subpools. Due to the
+ -- potential aliasing of masters in these two cases, do not process
+ -- the same master twice.
+
return;
end if;
diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb
index 6773aaa..4e69ea4 100644
--- a/gcc/ada/s-taprop-linux.adb
+++ b/gcc/ada/s-taprop-linux.adb
@@ -990,11 +990,18 @@ package body System.Task_Primitives.Operations is
-- do not need to manipulate caller's signal mask at this point.
-- All tasks in RTS will have All_Tasks_Mask initially.
- Result := pthread_create
- (T.Common.LL.Thread'Access,
- Attributes'Access,
- Thread_Body_Access (Wrapper),
- To_Address (T));
+ -- Note: the use of Unrestricted_Access in the following call is needed
+ -- because otherwise we have an error of getting a access-to-volatile
+ -- value which points to a non-volatile object. But in this case it is
+ -- safe to do this, since we know we have no problems with aliasing and
+ -- Unrestricted_Access bypasses this check.
+
+ Result :=
+ pthread_create
+ (T.Common.LL.Thread'Unrestricted_Access,
+ Attributes'Access,
+ Thread_Body_Access (Wrapper),
+ To_Address (T));
pragma Assert
(Result = 0 or else Result = EAGAIN or else Result = ENOMEM);
diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb
index 92b6023..e3134a5 100644
--- a/gcc/ada/s-taprop-vms.adb
+++ b/gcc/ada/s-taprop-vms.adb
@@ -811,7 +811,7 @@ package body System.Task_Primitives.Operations is
Result :=
pthread_create
- (T.Common.LL.Thread'Access,
+ (T.Common.LL.Thread'Unrestricted_Access,
Attributes'Access,
Thread_Body_Access (Wrapper),
To_Address (T));
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 8aa644a..87edd0e 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -726,13 +726,33 @@ package body Sem_Ch3 is
-- If the access definition is the return type of another access to
-- function, scope is the current one, because it is the one of the
- -- current type declaration.
+ -- current type declaration, except for the pathological case below.
if Nkind_In (Related_Nod, N_Object_Declaration,
N_Access_Function_Definition)
then
Anon_Scope := Current_Scope;
+ -- A pathological case: function returning access functions that
+ -- return access functions, etc. Each anonymous access type created
+ -- is in the enclosing scope of the outermost function.
+
+ declare
+ Par : Node_Id;
+ begin
+ Par := Related_Nod;
+ while Nkind_In (Par,
+ N_Access_Function_Definition,
+ N_Access_Definition)
+ loop
+ Par := Parent (Par);
+ end loop;
+
+ if Nkind (Par) = N_Function_Specification then
+ Anon_Scope := Scope (Defining_Entity (Par));
+ end if;
+ end;
+
-- For the anonymous function result case, retrieve the scope of the
-- function specification's associated entity rather than using the
-- current scope. The current scope will be the function itself if the
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index ad59f95..5798ae0 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -11069,6 +11069,11 @@ package body Sem_Res is
N);
return True;
+ -- If it was legal in the generic, it's legal in the instance
+
+ elsif In_Instance_Body then
+ return True;
+
-- If both are tagged types, check legality of view conversions
elsif Is_Tagged_Type (Target_Type)
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index e1c2b1a..c073d20 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -8727,10 +8727,15 @@ package body Sem_Util is
then
return True;
- elsif Nkind (N) = N_Indexed_Component
- or else Nkind (N) = N_Selected_Component
+ elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component)
+ and then Is_Volatile_Prefix (Prefix (N))
then
- return Is_Volatile_Prefix (Prefix (N));
+ return True;
+
+ elsif Nkind (N) = N_Selected_Component
+ and then Is_Volatile (Entity (Selector_Name (N)))
+ then
+ return True;
else
return False;
@@ -10833,9 +10838,7 @@ package body Sem_Util is
-- source. This excludes, for example, calls to a dispatching
-- assignment operation when the left-hand side is tagged.
- if Modification_Comes_From_Source
- or else Alfa_Mode
- then
+ if Modification_Comes_From_Source or else Alfa_Mode then
Generate_Reference (Ent, Exp, 'm');
-- If the target of the assignment is the bound variable
diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads
index 1bf84af..1d13f6e 100644
--- a/gcc/ada/sinput.ads
+++ b/gcc/ada/sinput.ads
@@ -477,13 +477,13 @@ package Sinput is
-- In addition to the set of characters defined by the type in Types, in
-- wide character encoding, then the codes returning True for a call to
- -- System.UTF_32.Is_UTF_32_Line_Terminator are also recognized as ending
- -- a physical source line. This includes the standard codes defined above
- -- in addition to NEL (NEXT LINE), LINE SEPARATOR and PARAGRAPH SEPARATOR.
- -- Again, as in the case of VT and FF, the standard requires we recognize
- -- these as line terminators, but we consider them to be logical line
- -- terminators. The only physical line terminators recognized are the
- -- standard ones (CR, LF, or CR/LF).
+ -- System.UTF_32.Is_UTF_32_Line_Terminator are also recognized as ending a
+ -- source line. This includes the standard codes defined above in addition
+ -- to NEL (NEXT LINE), LINE SEPARATOR and PARAGRAPH SEPARATOR. Again, as in
+ -- the case of VT and FF, the standard requires we recognize these as line
+ -- terminators, but we consider them to be logical line terminators. The
+ -- only physical line terminators recognized are the standard ones (CR,
+ -- LF, or CR/LF).
-- However, we do not recognize the NEL (16#85#) character as having the
-- significance of an end of line character when operating in normal 8-bit