aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada
diff options
context:
space:
mode:
authorArnaud Charlet <charlet@gcc.gnu.org>2015-01-06 10:18:13 +0100
committerArnaud Charlet <charlet@gcc.gnu.org>2015-01-06 10:18:13 +0100
commita921e83c12b6b3ea5027113af94c2b105533ba14 (patch)
tree58e776a5b2adf29b90e597c48cb52509a78cfcb8 /gcc/ada
parentac16e74cdf9135046892193eeb6eee7c8a8d4123 (diff)
downloadgcc-a921e83c12b6b3ea5027113af94c2b105533ba14.zip
gcc-a921e83c12b6b3ea5027113af94c2b105533ba14.tar.gz
gcc-a921e83c12b6b3ea5027113af94c2b105533ba14.tar.bz2
[multiple changes]
2015-01-06 Robert Dewar <dewar@adacore.com> * exp_util.adb: Change name Name_Table_Boolean to Name_Table_Boolean1. * namet.adb: Change name Name_Table_Boolean to Name_Table_Boolean1 Introduce Name_Table_Boolean2/3. * namet.ads: Change name Name_Table_Boolean to Name_Table_Boolean1 Introduce Name_Table_Boolean2/3. * par-ch13.adb: Change name Name_Table_Boolean to Name_Table_Boolean1. 2015-01-06 Bob Duff <duff@adacore.com> * gnat_rm.texi: Improve documentation regarding No_Task_Termination. 2015-01-06 Ed Schonberg <schonberg@adacore.com> * sem_aggr.adb (Resolve_Record_Aggregte, Get_Value): For an others choice that covers multiple components, analyze each copy with the type of the component even in compile-only mode, to detect potential accessibility errors. 2015-01-06 Hristian Kirtchev <kirtchev@adacore.com> * sem_res.adb (Is_Assignment_Or_Object_Expression): New routine. (Resolve_Actuals): An effectively volatile out parameter cannot act as an in or in out actual in a call. (Resolve_Entity_Name): An effectively volatile out parameter cannot be read. 2015-01-06 Ed Schonberg <schonberg@adacore.com> * sem_ch6.adb (Analyze_Subprogram_Body_Helper): If the body is the expansion of an expression function it may be pre-analyzed if a 'access attribute is applied to the function, in which case last_entity may have been assigned already. 2015-01-06 Ed Schonberg <schonberg@adacore.com> * sem_ch4.adb (Analyze_One_Call): If formal has an incomplete type and actual has the corresponding full view, there is no error, but a case of use of incomplete type in a predicate or invariant expression. 2015-01-06 Vincent Celier <celier@adacore.com> * makeutl.adb (Insert_No_Roots): Make sure that the same source in two different project tree is checked in both trees, if they are sources of two different projects, extended or not. 2015-01-06 Arnaud Charlet <charlet@adacore.com> * gnat1drv.adb: Minor code clean up. (Adjust_Global_Switches): Ignore gnatprove_mode in codepeer_mode. 2015-01-06 Bob Duff <duff@adacore.com> * osint.adb (Read_Source_File): Don't print out file name unless T = Source. 2015-01-06 Ed Schonberg <schonberg@adacore.com> * sem_util.adb (Is_Variable, Is_OK_Variable_For_Out_Formal): recognize improper uses of constant_reference types as actuals for in-out parameters. (Check_Function_Call): Do not collect identifiers if function name is missing because of previous error. From-SVN: r219231
Diffstat (limited to 'gcc/ada')
-rw-r--r--gcc/ada/ChangeLog68
-rw-r--r--gcc/ada/exp_util.adb2
-rw-r--r--gcc/ada/gnat1drv.adb5
-rw-r--r--gcc/ada/gnat_rm.texi12
-rw-r--r--gcc/ada/makeutl.adb7
-rw-r--r--gcc/ada/namet.adb76
-rw-r--r--gcc/ada/namet.ads28
-rw-r--r--gcc/ada/osint.adb44
-rw-r--r--gcc/ada/par-ch13.adb4
-rw-r--r--gcc/ada/sem_aggr.adb27
-rw-r--r--gcc/ada/sem_ch4.adb12
-rw-r--r--gcc/ada/sem_ch6.adb11
-rw-r--r--gcc/ada/sem_res.adb96
-rw-r--r--gcc/ada/sem_util.adb21
14 files changed, 343 insertions, 70 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index c67edc5..dde69e5 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,73 @@
2015-01-06 Robert Dewar <dewar@adacore.com>
+ * exp_util.adb: Change name Name_Table_Boolean to
+ Name_Table_Boolean1.
+ * namet.adb: Change name Name_Table_Boolean to Name_Table_Boolean1
+ Introduce Name_Table_Boolean2/3.
+ * namet.ads: Change name Name_Table_Boolean to Name_Table_Boolean1
+ Introduce Name_Table_Boolean2/3.
+ * par-ch13.adb: Change name Name_Table_Boolean to
+ Name_Table_Boolean1.
+
+2015-01-06 Bob Duff <duff@adacore.com>
+
+ * gnat_rm.texi: Improve documentation regarding No_Task_Termination.
+
+2015-01-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_aggr.adb (Resolve_Record_Aggregte, Get_Value): For an
+ others choice that covers multiple components, analyze each
+ copy with the type of the component even in compile-only mode,
+ to detect potential accessibility errors.
+
+2015-01-06 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_res.adb (Is_Assignment_Or_Object_Expression): New routine.
+ (Resolve_Actuals): An effectively volatile out
+ parameter cannot act as an in or in out actual in a call.
+ (Resolve_Entity_Name): An effectively volatile out parameter
+ cannot be read.
+
+2015-01-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): If the body is
+ the expansion of an expression function it may be pre-analyzed
+ if a 'access attribute is applied to the function, in which case
+ last_entity may have been assigned already.
+
+2015-01-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch4.adb (Analyze_One_Call): If formal has an incomplete
+ type and actual has the corresponding full view, there is no
+ error, but a case of use of incomplete type in a predicate or
+ invariant expression.
+
+2015-01-06 Vincent Celier <celier@adacore.com>
+
+ * makeutl.adb (Insert_No_Roots): Make sure that the same source
+ in two different project tree is checked in both trees, if they
+ are sources of two different projects, extended or not.
+
+2015-01-06 Arnaud Charlet <charlet@adacore.com>
+
+ * gnat1drv.adb: Minor code clean up.
+ (Adjust_Global_Switches): Ignore gnatprove_mode in codepeer_mode.
+
+2015-01-06 Bob Duff <duff@adacore.com>
+
+ * osint.adb (Read_Source_File): Don't print out
+ file name unless T = Source.
+
+2015-01-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_util.adb (Is_Variable, Is_OK_Variable_For_Out_Formal):
+ recognize improper uses of constant_reference types as actuals
+ for in-out parameters.
+ (Check_Function_Call): Do not collect identifiers if function
+ name is missing because of previous error.
+
+2015-01-06 Robert Dewar <dewar@adacore.com>
+
* ali-util.adb, sem_prag.adb, rtsfind.adb, sem_util.adb, sem_res.adb,
ali.adb, binde.adb, namet.adb, namet.ads, gnatls.adb, bcheck.adb:
Minor change of name Name_Table_Info => Name_Table_Int.
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index f1f6b52..47acc6f 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -2963,7 +2963,7 @@ package body Exp_Util is
-- If parser detected no address clause for the identifier in question,
-- then the answer is a quick NO, without the need for a search.
- if not Get_Name_Table_Boolean (Chars (Id)) then
+ if not Get_Name_Table_Boolean1 (Chars (Id)) then
return Empty;
end if;
diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb
index 81eb639..b4e74f4 100644
--- a/gcc/ada/gnat1drv.adb
+++ b/gcc/ada/gnat1drv.adb
@@ -182,6 +182,11 @@ procedure Gnat1drv is
if CodePeer_Mode then
+ -- Turn off gnatprove mode (if set via e.g. -gnatd.F), not compatible
+ -- with CodePeer mode.
+
+ GNATprove_Mode := False;
+
-- Turn off inlining, confuses CodePeer output and gains nothing
Front_End_Inlining := False;
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index 6bf9462..b78bc51 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -10972,7 +10972,7 @@ directly on the environment task of the partition.
@node No_Task_Termination
@unnumberedsubsec No_Task_Termination
@findex No_Task_Termination
-[RM D.7] Tasks which terminate are erroneous.
+[RM D.7] Tasks that terminate are erroneous.
@node No_Tasking
@unnumberedsubsec No_Tasking
@@ -14319,6 +14319,16 @@ task creation.
@item
@cartouche
@noindent
+What happens when a task terminates in the presence of
+pragma @code{No_Task_Termination}. See D.7(15).
+@end cartouche
+@noindent
+Execution is erroneous in that case.
+
+@sp 1
+@item
+@cartouche
+@noindent
Implementation-defined aspects of pragma
@code{Restrictions}. See D.7(20).
@end cartouche
diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb
index cbfd01e..5960d3e 100644
--- a/gcc/ada/makeutl.adb
+++ b/gcc/ada/makeutl.adb
@@ -2557,8 +2557,11 @@ package body Makeutl is
for J in 1 .. Q.Last loop
if Source.Id.Path.Name = Q.Table (J).Info.Id.Path.Name
and then Source.Id.Index = Q.Table (J).Info.Id.Index
- and then Source.Id.Project.Path.Name =
- Q.Table (J).Info.Id.Project.Path.Name
+ and then
+ Ultimate_Extending_Project_Of (Source.Id.Project).Path.Name
+ =
+ Ultimate_Extending_Project_Of (Q.Table (J).Info.Id.Project).
+ Path.Name
then
-- No need to insert this source in the queue, but still
-- return True as we may need to insert its roots.
diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb
index d0dfee2..0eab3a1 100644
--- a/gcc/ada/namet.adb
+++ b/gcc/ada/namet.adb
@@ -705,15 +705,35 @@ package body Namet is
end loop;
end Get_Name_String_And_Append;
- ----------------------------
- -- Get_Name_Table_Boolean --
- ----------------------------
+ -----------------------------
+ -- Get_Name_Table_Boolean1 --
+ -----------------------------
+
+ function Get_Name_Table_Boolean1 (Id : Name_Id) return Boolean is
+ begin
+ pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
+ return Name_Entries.Table (Id).Boolean1_Info;
+ end Get_Name_Table_Boolean1;
+
+ -----------------------------
+ -- Get_Name_Table_Boolean2 --
+ -----------------------------
+
+ function Get_Name_Table_Boolean2 (Id : Name_Id) return Boolean is
+ begin
+ pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
+ return Name_Entries.Table (Id).Boolean2_Info;
+ end Get_Name_Table_Boolean2;
+
+ -----------------------------
+ -- Get_Name_Table_Boolean3 --
+ -----------------------------
- function Get_Name_Table_Boolean (Id : Name_Id) return Boolean is
+ function Get_Name_Table_Boolean3 (Id : Name_Id) return Boolean is
begin
pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
- return Name_Entries.Table (Id).Boolean_Info;
- end Get_Name_Table_Boolean;
+ return Name_Entries.Table (Id).Boolean3_Info;
+ end Get_Name_Table_Boolean3;
-------------------------
-- Get_Name_Table_Byte --
@@ -933,7 +953,9 @@ package body Namet is
Name_Len => Short (Name_Len),
Byte_Info => 0,
Int_Info => 0,
- Boolean_Info => False,
+ Boolean1_Info => False,
+ Boolean2_Info => False,
+ Boolean3_Info => False,
Name_Has_No_Encodings => False,
Hash_Link => No_Name));
@@ -1037,7 +1059,9 @@ package body Namet is
Name_Has_No_Encodings => False,
Int_Info => 0,
Byte_Info => 0,
- Boolean_Info => False));
+ Boolean1_Info => False,
+ Boolean2_Info => False,
+ Boolean3_Info => False));
-- Set corresponding string entry in the Name_Chars table
@@ -1262,7 +1286,9 @@ package body Namet is
Name_Len => 1,
Byte_Info => 0,
Int_Info => 0,
- Boolean_Info => False,
+ Boolean1_Info => False,
+ Boolean2_Info => False,
+ Boolean3_Info => False,
Name_Has_No_Encodings => True,
Hash_Link => No_Name));
@@ -1300,15 +1326,35 @@ package body Namet is
Store_Encoded_Character (C);
end Set_Character_Literal_Name;
- ----------------------------
- -- Set_Name_Table_Boolean --
- ----------------------------
+ -----------------------------
+ -- Set_Name_Table_Boolean1 --
+ -----------------------------
+
+ procedure Set_Name_Table_Boolean1 (Id : Name_Id; Val : Boolean) is
+ begin
+ pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
+ Name_Entries.Table (Id).Boolean1_Info := Val;
+ end Set_Name_Table_Boolean1;
+
+ -----------------------------
+ -- Set_Name_Table_Boolean2 --
+ -----------------------------
+
+ procedure Set_Name_Table_Boolean2 (Id : Name_Id; Val : Boolean) is
+ begin
+ pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
+ Name_Entries.Table (Id).Boolean2_Info := Val;
+ end Set_Name_Table_Boolean2;
+
+ -----------------------------
+ -- Set_Name_Table_Boolean3 --
+ -----------------------------
- procedure Set_Name_Table_Boolean (Id : Name_Id; Val : Boolean) is
+ procedure Set_Name_Table_Boolean3 (Id : Name_Id; Val : Boolean) is
begin
pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
- Name_Entries.Table (Id).Boolean_Info := Val;
- end Set_Name_Table_Boolean;
+ Name_Entries.Table (Id).Boolean3_Info := Val;
+ end Set_Name_Table_Boolean3;
-------------------------
-- Set_Name_Table_Byte --
diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads
index 4e025c7..b4b6878 100644
--- a/gcc/ada/namet.ads
+++ b/gcc/ada/namet.ads
@@ -115,7 +115,7 @@ package Namet is
-- character lower case letters in the range a-z, and these names are created
-- and initialized by the Initialize procedure.
--- Three values, one of type Int, one of type Byte, and one of type Boolean,
+-- Five values, one of type Int, one of type Byte, and three of type Boolean,
-- are stored with each names table entry and subprograms are provided for
-- setting and retrieving these associated values. The usage of these values
-- is up to the client:
@@ -128,9 +128,11 @@ package Namet is
-- The Byte field is used to hold the Token_Type value for reserved words
-- (see Sem for details).
--- The Boolean field is used to mark address clauses to optimize the
+-- The Boolean1 field is used to mark address clauses to optimize the
-- performance of the Exp_Util.Following_Address_Clause function.
+-- The Boolean2/Boolean3 fields are not used
+
-- In the binder, we have the following uses:
-- The Int field is used in various ways depending on the name involved,
@@ -367,8 +369,10 @@ package Namet is
pragma Inline (Get_Name_Table_Int);
-- Fetches the Int value associated with the given name
- function Get_Name_Table_Boolean (Id : Name_Id) return Boolean;
- -- Fetches the Boolean value associated with the given name
+ function Get_Name_Table_Boolean1 (Id : Name_Id) return Boolean;
+ function Get_Name_Table_Boolean2 (Id : Name_Id) return Boolean;
+ function Get_Name_Table_Boolean3 (Id : Name_Id) return Boolean;
+ -- Fetches the Boolean values associated with the given name
function Is_Operator_Name (Id : Name_Id) return Boolean;
-- Returns True if name given is of the form of an operator (that
@@ -504,7 +508,9 @@ package Namet is
pragma Inline (Set_Name_Table_Byte);
-- Sets the Byte value associated with the given name
- procedure Set_Name_Table_Boolean (Id : Name_Id; Val : Boolean);
+ procedure Set_Name_Table_Boolean1 (Id : Name_Id; Val : Boolean);
+ procedure Set_Name_Table_Boolean2 (Id : Name_Id; Val : Boolean);
+ procedure Set_Name_Table_Boolean3 (Id : Name_Id; Val : Boolean);
-- Sets the Boolean value associated with the given name
procedure Store_Encoded_Character (C : Char_Code);
@@ -644,8 +650,10 @@ private
Byte_Info : Byte;
-- Byte value associated with this name
- Boolean_Info : Boolean;
- -- Boolean value associated with the name
+ Boolean1_Info : Boolean;
+ Boolean2_Info : Boolean;
+ Boolean3_Info : Boolean;
+ -- Boolean values associated with the name
Name_Has_No_Encodings : Boolean;
-- This flag is set True if the name entry is known not to contain any
@@ -665,8 +673,10 @@ private
Name_Chars_Index at 0 range 0 .. 31;
Name_Len at 4 range 0 .. 15;
Byte_Info at 6 range 0 .. 7;
- Boolean_Info at 7 range 0 .. 0;
- Name_Has_No_Encodings at 7 range 1 .. 7;
+ Boolean1_Info at 7 range 0 .. 0;
+ Boolean2_Info at 7 range 1 .. 1;
+ Boolean3_Info at 7 range 2 .. 2;
+ Name_Has_No_Encodings at 7 range 3 .. 7;
Hash_Link at 8 range 0 .. 31;
Int_Info at 12 range 0 .. 31;
end record;
diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb
index 9ba1808..f78a8ea 100644
--- a/gcc/ada/osint.adb
+++ b/gcc/ada/osint.adb
@@ -2642,31 +2642,33 @@ package body Osint is
return;
end if;
- -- Print out the file name, if requested, and if it's not part of the
- -- runtimes, store it in File_Name_Chars.
+ -- If it's a Source file, print out the file name, if requested, and if
+ -- it's not part of the runtimes, store it in File_Name_Chars. We don't
+ -- want to print non-Source files, like GNAT-TEMP-000001.TMP used to
+ -- pass information from gprbuild to gcc. We don't want to save runtime
+ -- file names, because we don't want users to send them in bug reports.
- declare
- Name : String renames Name_Buffer (1 .. Name_Len);
- Inc : String renames Include_Dir_Default_Prefix.all;
-
- begin
- if Debug.Debug_Flag_Dot_N then
- Write_Line (Name);
- end if;
+ if T = Source then
+ declare
+ Name : String renames Name_Buffer (1 .. Name_Len);
+ Inc : String renames Include_Dir_Default_Prefix.all;
- if Inc /= ""
- and then Inc'Length < Name_Len
- and then Name_Buffer (1 .. Inc'Length) = Inc
- then
- -- Part of runtimes, so ignore it
+ Part_Of_Runtimes : constant Boolean :=
+ Inc /= ""
+ and then Inc'Length < Name_Len
+ and then Name_Buffer (1 .. Inc'Length) = Inc;
- null;
+ begin
+ if Debug.Debug_Flag_Dot_N then
+ Write_Line (Name);
+ end if;
- else
- File_Name_Chars.Append_All (File_Name_Chars.Table_Type (Name));
- File_Name_Chars.Append (ASCII.LF);
- end if;
- end;
+ if not Part_Of_Runtimes then
+ File_Name_Chars.Append_All (File_Name_Chars.Table_Type (Name));
+ File_Name_Chars.Append (ASCII.LF);
+ end if;
+ end;
+ end if;
-- Prepare to read data from the file
diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb
index 0bbca43..5d4f7d2 100644
--- a/gcc/ada/par-ch13.adb
+++ b/gcc/ada/par-ch13.adb
@@ -741,7 +741,7 @@ package body Ch13 is
if Attr_Name = Name_Address
and then Nkind (Prefix_Node) = N_Identifier
then
- Set_Name_Table_Boolean (Chars (Prefix_Node), True);
+ Set_Name_Table_Boolean1 (Chars (Prefix_Node), True);
end if;
end loop;
@@ -771,7 +771,7 @@ package body Ch13 is
-- Mark occurrence of address clause (used to optimize performance
-- of Exp_Util.Following_Address_Clause).
- Set_Name_Table_Boolean (Chars (Identifier_Node), True);
+ Set_Name_Table_Boolean1 (Chars (Identifier_Node), True);
-- RECORD follows USE (Record Representation Clause)
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 82d6ce0..f6c0bd7 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -3227,17 +3227,36 @@ package body Sem_Aggr is
if Present (Others_Etype)
and then Base_Type (Others_Etype) /= Base_Type (Typ)
then
- Error_Msg_N
- ("components in OTHERS choice must "
- & "have same type", Selector_Name);
+ -- If the components are of an anonymous access
+ -- type they are distinct, but this is legal in
+ -- Ada 2012 as long as designated types match.
+
+ if (Ekind (Typ) = E_Anonymous_Access_Type
+ or else Ekind (Typ) =
+ E_Anonymous_Access_Subprogram_Type)
+ and then Designated_Type (Typ) =
+ Designated_Type (Others_Etype)
+ then
+ null;
+ else
+ Error_Msg_N
+ ("components in OTHERS choice must "
+ & "have same type", Selector_Name);
+ end if;
end if;
Others_Etype := Typ;
- if Expander_Active then
+ -- Copy expression so that it is resolved
+ -- independently for each component, This is needed
+ -- for accessibility checks on compoents of anonymous
+ -- access types, even in compile_only mode.
+
+ if not Inside_A_Generic then
return
New_Copy_Tree_And_Copy_Dimensions
(Expression (Assoc));
+
else
return Expression (Assoc);
end if;
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 0167f90..8ddced8 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -3195,6 +3195,18 @@ package body Sem_Ch4 is
Next_Actual (Actual);
Next_Formal (Formal);
+ -- For an Ada 2012 predicate or invariant, a call may mention
+ -- an incomplete type, while resolution of the corresponding
+ -- predicate function may see the full view, as a consequence
+ -- of the delayed resolution of the corresponding expressions.
+
+ elsif Ekind (Etype (Formal)) = E_Incomplete_Type
+ and then Full_View (Etype (Formal)) = Etype (Actual)
+ then
+ Set_Etype (Formal, Etype (Actual));
+ Next_Actual (Actual);
+ Next_Formal (Formal);
+
else
if Debug_Flag_E then
Write_Str (" type checking fails in call ");
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 946f217..8962079 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -3950,8 +3950,17 @@ package body Sem_Ch6 is
-- Case where there are no spec entities, in this case there can be
-- no body entities either, so just move everything.
+ -- If the body is generated for an expression function, it may have
+ -- been preanalyzed already, if 'access was applied to it.
+
else
- pragma Assert (No (Last_Entity (Body_Id)));
+ if Nkind (Original_Node (Unit_Declaration_Node (Spec_Id))) /=
+ N_Expression_Function
+ then
+ pragma Assert (No (Last_Entity (Body_Id)));
+ null;
+ end if;
+
Set_First_Entity (Body_Id, First_Entity (Spec_Id));
Set_Last_Entity (Body_Id, Last_Entity (Spec_Id));
Set_First_Entity (Spec_Id, Empty);
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 336b186..445ded4 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -4250,14 +4250,25 @@ package body Sem_Res is
end if;
-- In Ada 83 we cannot pass an OUT parameter as an IN or IN OUT
- -- actual to a nested call, since this is case of reading an
- -- out parameter, which is not allowed.
+ -- actual to a nested call, since this constitutes a reading of
+ -- the parameter, which is not allowed.
- if Ada_Version = Ada_83
- and then Is_Entity_Name (A)
+ if Is_Entity_Name (A)
and then Ekind (Entity (A)) = E_Out_Parameter
then
- Error_Msg_N ("(Ada 83) illegal reading of out parameter", A);
+ if Ada_Version = Ada_83 then
+ Error_Msg_N
+ ("(Ada 83) illegal reading of out parameter", A);
+
+ -- An effectively volatile OUT parameter cannot act as IN or
+ -- IN OUT actual in a call (SPARK RM 7.1.3(11)).
+
+ elsif SPARK_Mode = On
+ and then Is_Effectively_Volatile (Entity (A))
+ then
+ Error_Msg_N
+ ("illegal reading of volatile OUT parameter", A);
+ end if;
end if;
end if;
@@ -5444,8 +5455,8 @@ package body Sem_Res is
N_Unchecked_Type_Conversion)
then
Error_Msg_N
- ("(Ada 83) fixed-point operation "
- & "needs explicit conversion", N);
+ ("(Ada 83) fixed-point operation needs explicit "
+ & "conversion", N);
end if;
-- The expected type is "any real type" in contexts like
@@ -6886,6 +6897,12 @@ package body Sem_Res is
-- Used to resolve identifiers and expanded names
procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id) is
+ function Is_Assignment_Or_Object_Expression
+ (Context : Node_Id;
+ Expr : Node_Id) return Boolean;
+ -- Determine whether node Context denotes an assignment statement or an
+ -- object declaration whose expression is node Expr.
+
function Is_OK_Volatile_Context
(Context : Node_Id;
Obj_Ref : Node_Id) return Boolean;
@@ -6893,6 +6910,48 @@ package body Sem_Res is
-- (as defined in SPARK RM 7.1.3(13)) where volatile reference Obj_Ref
-- can safely reside.
+ ----------------------------------------
+ -- Is_Assignment_Or_Object_Expression --
+ ----------------------------------------
+
+ function Is_Assignment_Or_Object_Expression
+ (Context : Node_Id;
+ Expr : Node_Id) return Boolean
+ is
+ begin
+ if Nkind_In (Context, N_Assignment_Statement,
+ N_Object_Declaration)
+ and then Expression (Context) = Expr
+ then
+ return True;
+
+ -- Check whether a construct that yields a name is the expression of
+ -- an assignment statement or an object declaration.
+
+ elsif (Nkind_In (Context, N_Attribute_Reference,
+ N_Explicit_Dereference,
+ N_Indexed_Component,
+ N_Selected_Component,
+ N_Slice)
+ and then Prefix (Context) = Expr)
+ or else
+ (Nkind_In (Context, N_Type_Conversion,
+ N_Unchecked_Type_Conversion)
+ and then Expression (Context) = Expr)
+ then
+ return
+ Is_Assignment_Or_Object_Expression
+ (Context => Parent (Context),
+ Expr => Context);
+
+ -- Otherwise the context is not an assignment statement or an object
+ -- declaration.
+
+ else
+ return False;
+ end if;
+ end Is_Assignment_Or_Object_Expression;
+
----------------------------
-- Is_OK_Volatile_Context --
----------------------------
@@ -6992,6 +7051,7 @@ package body Sem_Res is
-- in a non-interfering context.
elsif Nkind_In (Context, N_Attribute_Reference,
+ N_Explicit_Dereference,
N_Indexed_Component,
N_Selected_Component,
N_Slice)
@@ -7107,14 +7167,26 @@ package body Sem_Res is
elsif Ekind (E) = E_Generic_Function then
Error_Msg_N ("illegal use of generic function", N);
+ -- In Ada 83 an OUT parameter cannot be read
+
elsif Ekind (E) = E_Out_Parameter
- and then Ada_Version = Ada_83
and then (Nkind (Parent (N)) in N_Op
- or else (Nkind (Parent (N)) = N_Assignment_Statement
- and then N = Expression (Parent (N)))
- or else Nkind (Parent (N)) = N_Explicit_Dereference)
+ or else Nkind (Parent (N)) = N_Explicit_Dereference
+ or else Is_Assignment_Or_Object_Expression
+ (Context => Parent (N),
+ Expr => N))
then
- Error_Msg_N ("(Ada 83) illegal reading of out parameter", N);
+ if Ada_Version = Ada_83 then
+ Error_Msg_N ("(Ada 83) illegal reading of out parameter", N);
+
+ -- An effectively volatile OUT parameter cannot be read
+ -- (SPARK RM 7.1.3(11)).
+
+ elsif SPARK_Mode = On
+ and then Is_Effectively_Volatile (E)
+ then
+ Error_Msg_N ("illegal reading of volatile OUT parameter", N);
+ end if;
-- In all other cases, just do the possible static evaluation
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 65f3343..a93139e 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -2133,6 +2133,12 @@ package body Sem_Util is
begin
Id := Get_Function_Id (Call);
+ -- In case of previous error, no check is posible.
+
+ if No (Id) then
+ return Abandon;
+ end if;
+
Formal := First_Formal (Id);
Actual := First_Actual (Call);
while Present (Actual) and then Present (Formal) loop
@@ -11621,6 +11627,18 @@ package body Sem_Util is
elsif Is_Variable (AV) then
return True;
+ -- Generalized indexing operations are rewritten as explicit
+ -- dereferences, and it is only during resolution that we can
+ -- check whether the context requires an access_to_variable type.
+
+ elsif Nkind (AV) = N_Explicit_Dereference
+ and then Ada_Version >= Ada_2012
+ and then Nkind (Original_Node (AV)) = N_Indexed_Component
+ and then Present (Etype (Original_Node (AV)))
+ and then Has_Implicit_Dereference (Etype (Original_Node (AV)))
+ then
+ return not Is_Access_Constant (Etype (Prefix (AV)));
+
-- Unchecked conversions are allowed only if they come from the
-- generated code, which sometimes uses unchecked conversions for out
-- parameters in cases where code generation is unaffected. We tell
@@ -12857,9 +12875,8 @@ package body Sem_Util is
and then Present (Etype (Orig_Node))
and then Ada_Version >= Ada_2012
and then Has_Implicit_Dereference (Etype (Orig_Node))
- and then not Is_Access_Constant (Etype (Prefix (N)))
then
- return True;
+ return not Is_Access_Constant (Etype (Prefix (N)));
-- A function call is never a variable