aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--gcc/ada/ChangeLog31
-rw-r--r--gcc/ada/a-locale.adb9
-rw-r--r--gcc/ada/a-locale.ads11
-rw-r--r--gcc/ada/inline.adb12
-rw-r--r--gcc/ada/sem_ch13.adb12
-rw-r--r--gcc/ada/sem_ch3.adb20
-rw-r--r--gcc/ada/sem_ch4.adb33
-rw-r--r--gcc/ada/sem_ch5.adb8
-rw-r--r--gcc/ada/sem_res.adb5
9 files changed, 115 insertions, 26 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 428648a..252efc5 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,36 @@
2017-01-20 Yannick Moy <moy@adacore.com>
+ * inline.adb (Expand_Inlined_Call): Keep more
+ precise type of actual for inlining whenever possible. In
+ particular, do not switch to the formal type in GNATprove mode in
+ some case where the GNAT backend might require it for visibility.
+
+2017-01-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Check_Non_Overridable_Aspects): An inherited
+ aspect Implicit_Dereference can be inherited by a full view if
+ the partial view has no discriminants, because there is no way
+ to apply the aspect to the partial view.
+ (Build_Derived_Record_Type): If derived type renames discriminants
+ of the parent, the new discriminant inherits the aspect from
+ the old one.
+ * sem_ch4.adb (Analyze_Call): Handle properly a parameterless
+ call through an access discriminant designating a subprogram.
+ * sem_ch5.adb (Analyze_Assignment): (Analyze_Call): Handle
+ properly a parameterless call through an access discriminant on
+ the left-hand side of an assignment.
+ * sem_res.adb (resolve): If an interpreation involves a
+ discriminant with an implicit dereference and the expression is an
+ entity, resolution takes place later in the appropriate routine.
+ * sem_ch13.adb (Analyze_Aspect_Implicit_Dereference): Recognize
+ access discriminants that designate a subprogram type.
+
+2017-01-20 Pascal Obry <obry@adacore.com>
+
+ * a-locale.adb, a-locale.ads: Update Ada.Locales for RM 2012 COR:1:2016
+
+2017-01-20 Yannick Moy <moy@adacore.com>
+
* sem_ch10.adb (Check_No_Elab_Code_All): Do not issue an error
on implicitly with'ed units in GNATprove mode.
* sinfo.ads (Implicit_With): Document use of flag for implicitly
diff --git a/gcc/ada/a-locale.adb b/gcc/ada/a-locale.adb
index d56970c..60ad079 100644
--- a/gcc/ada/a-locale.adb
+++ b/gcc/ada/a-locale.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2016, 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- --
@@ -33,8 +33,7 @@ with System; use System;
package body Ada.Locales is
- type Lower_4 is array (1 .. 4) of Character range 'a' .. 'z';
- type Upper_4 is array (1 .. 4) of Character range 'A' .. 'Z';
+ type Str_4 is new String (1 .. 4);
--------------
-- Language --
@@ -43,7 +42,7 @@ package body Ada.Locales is
function Language return Language_Code is
procedure C_Get_Language_Code (P : Address);
pragma Import (C, C_Get_Language_Code);
- F : Lower_4;
+ F : Str_4;
begin
C_Get_Language_Code (F'Address);
return Language_Code (F (1 .. 3));
@@ -56,7 +55,7 @@ package body Ada.Locales is
function Country return Country_Code is
procedure C_Get_Country_Code (P : Address);
pragma Import (C, C_Get_Country_Code);
- F : Upper_4;
+ F : Str_4;
begin
C_Get_Country_Code (F'Address);
return Country_Code (F (1 .. 2));
diff --git a/gcc/ada/a-locale.ads b/gcc/ada/a-locale.ads
index 629f367..132c883 100644
--- a/gcc/ada/a-locale.ads
+++ b/gcc/ada/a-locale.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
@@ -19,8 +19,13 @@ package Ada.Locales is
pragma Preelaborate (Locales);
pragma Remote_Types (Locales);
- type Language_Code is array (1 .. 3) of Character range 'a' .. 'z';
- type Country_Code is array (1 .. 2) of Character range 'A' .. 'Z';
+ type Language_Code is new String (1 .. 3)
+ with Dynamic_Predicate =>
+ (for all E of Language_Code => E in 'a' .. 'z');
+
+ type Country_Code is new String (1 .. 2)
+ with Dynamic_Predicate =>
+ (for all E of Country_Code => E in 'A' .. 'Z');
Language_Unknown : constant Language_Code := "und";
Country_Unknown : constant Country_Code := "ZZ";
diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb
index 9fb47ef..f1afe32 100644
--- a/gcc/ada/inline.adb
+++ b/gcc/ada/inline.adb
@@ -3087,8 +3087,10 @@ package body Inline is
elsif Base_Type (Etype (F)) = Base_Type (Etype (A))
and then Etype (F) /= Base_Type (Etype (F))
+ and then Is_Constrained (Etype (F))
then
Temp_Typ := Etype (F);
+
else
Temp_Typ := Etype (A);
end if;
@@ -3150,7 +3152,15 @@ package body Inline is
Subtype_Mark => New_Occurrence_Of (Etype (F), Loc),
Expression => Relocate_Node (Expression (A)));
- elsif Etype (F) /= Etype (A) then
+ -- In GNATprove mode, keep the most precise type of the actual
+ -- for the temporary variable. Otherwise, the AST may contain
+ -- unexpected assignment statements to a temporary variable of
+ -- unconstrained type renaming a local variable of constrained
+ -- type, which is not expected by GNATprove.
+
+ elsif Etype (F) /= Etype (A)
+ and then not GNATprove_Mode
+ then
New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A));
Temp_Typ := Etype (F);
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 55aea49..8f1ce7d 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -1808,11 +1808,17 @@ package body Sem_Ch13 is
("aspect must name a discriminant of current type", Expr);
else
+
+ -- Discriminant type be an anonymous access type or an
+ -- anonymous access to subprogram.
+ -- Missing synchronized types???
+
Disc := First_Discriminant (E);
while Present (Disc) loop
if Chars (Expr) = Chars (Disc)
- and then Ekind (Etype (Disc)) =
- E_Anonymous_Access_Type
+ and then Ekind_In (Etype (Disc),
+ E_Anonymous_Access_Type,
+ E_Anonymous_Access_Subprogram_Type)
then
Set_Has_Implicit_Dereference (E);
Set_Has_Implicit_Dereference (Disc);
@@ -8684,7 +8690,7 @@ package body Sem_Ch13 is
Expression => Expr))));
-- If declaration has not been analyzed yet, Insert declaration
- -- before freeze node. Insert body itself after freeze node.
+ -- before freeze node. Insert body itself after freeze node.
if not Analyzed (FDecl) then
Insert_Before_And_Analyze (N, FDecl);
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 68b7323..93b80a8 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -2836,6 +2836,8 @@ package body Sem_Ch3 is
then
if
not Has_Aspect_Spec (Prev_Aspects, Name_Implicit_Dereference)
+ and then Present
+ (Discriminant_Specifications (Original_Node (Parent (Prev))))
then
Error_Msg_N
("type does not inherit implicit dereference", Prev);
@@ -8973,6 +8975,9 @@ package body Sem_Ch3 is
-- STEP 5a: Copy the parent record declaration for untagged types
+ Set_Has_Implicit_Dereference
+ (Derived_Type, Has_Implicit_Dereference (Parent_Type));
+
if not Is_Tagged then
-- Discriminant_Constraint (Derived_Type) has been properly
@@ -9015,8 +9020,6 @@ package body Sem_Ch3 is
Set_Stored_Constraint
(Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs));
Replace_Components (Derived_Type, New_Decl);
- Set_Has_Implicit_Dereference
- (Derived_Type, Has_Implicit_Dereference (Parent_Type));
end if;
-- Insert the new derived type declaration
@@ -9635,12 +9638,19 @@ package body Sem_Ch3 is
-- If any of the discriminant constraints is given by a
-- discriminant and we are in a derived type declaration we
-- have a discriminant renaming. Establish link between new
- -- and old discriminant.
+ -- and old discriminant. The new discriminant has an implicit
+ -- dereference if the old one does.
if Denotes_Discriminant (Discr_Expr (J)) then
if Derived_Def then
- Set_Corresponding_Discriminant
- (Entity (Discr_Expr (J)), Discr);
+ declare
+ New_Discr : constant Entity_Id := Entity (Discr_Expr (J));
+
+ begin
+ Set_Corresponding_Discriminant (New_Discr, Discr);
+ Set_Has_Implicit_Dereference (New_Discr,
+ Has_Implicit_Dereference (Discr));
+ end;
end if;
-- Force the evaluation of non-discriminant expressions.
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 56da406..8ae620c 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -913,6 +913,7 @@ package body Sem_Ch4 is
-- the type-checking is similar to that of other calls.
procedure Analyze_Call (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
Actuals : constant List_Id := Parameter_Associations (N);
Nam : Node_Id;
X : Interp_Index;
@@ -1310,17 +1311,32 @@ package body Sem_Ch4 is
-- If the interpretation succeeds, mark the proper type of the
-- prefix (any valid candidate will do). If not, remove the
- -- candidate interpretation. This only needs to be done for
- -- overloaded protected operations, for other entities disambi-
- -- guation is done directly in Resolve.
+ -- candidate interpretation. If this is a parameterless call
+ -- on an anonymous access to subprogram, X is a variable with
+ -- an access discriminant D, the entity in the interpretation is
+ -- D, so rewrite X as X.D.all.
if Success then
if Deref
and then Nkind (Parent (N)) /= N_Explicit_Dereference
then
- Set_Entity (Nam, It.Nam);
- Insert_Explicit_Dereference (Nam);
- Set_Etype (Nam, Nam_Ent);
+ if Ekind (It.Nam) = E_Discriminant
+ and then Has_Implicit_Dereference (It.Nam)
+ then
+ Rewrite (Name (N),
+ Make_Explicit_Dereference (Loc,
+ Prefix => Make_Selected_Component (Loc,
+ Prefix =>
+ (New_Occurrence_Of (Entity (Nam), Loc)),
+ Selector_Name => New_Occurrence_Of (It.Nam, Loc))));
+ Analyze (N);
+ return;
+
+ else
+ Set_Entity (Nam, It.Nam);
+ Insert_Explicit_Dereference (Nam);
+ Set_Etype (Nam, Nam_Ent);
+ end if;
else
Set_Etype (Nam, It.Typ);
@@ -7981,10 +7997,12 @@ package body Sem_Ch4 is
if not Is_Overloaded (Func_Name) then
Func := Entity (Func_Name);
+
Indexing :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Func, Loc),
Parameter_Associations => Assoc);
+
Set_Parent (Indexing, Parent (N));
Set_Generalized_Indexing (N, Indexing);
Analyze (Indexing);
@@ -8009,7 +8027,6 @@ package body Sem_Ch4 is
Name =>
Make_Identifier (Loc, Chars (Func_Name)),
Parameter_Associations => Assoc);
-
Set_Parent (Indexing, Parent (N));
Set_Generalized_Indexing (N, Indexing);
Set_Etype (N, Any_Type);
@@ -8024,7 +8041,7 @@ package body Sem_Ch4 is
Get_First_Interp (Func_Name, I, It);
Set_Etype (Indexing, Any_Type);
- -- Analyze eacn candidae function with the given actuals
+ -- Analyze each candidate function with the given actuals
while Present (It.Nam) loop
Analyze_One_Call (Indexing, It.Nam, False, Success);
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 0a72320..6962262 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -330,6 +330,14 @@ package body Sem_Ch5 is
then
null;
+ -- This may be a call to a parameterless function through an
+ -- implicit dereference, so discard interpretation as well.
+
+ elsif Is_Entity_Name (Lhs)
+ and then Has_Implicit_Dereference (It.Typ)
+ then
+ null;
+
elsif Has_Compatible_Type (Rhs, It.Typ) then
if T1 /= Any_Type then
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 3728482..062a839 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -2469,6 +2469,7 @@ package body Sem_Res is
N_Attribute_Reference,
N_And_Then,
N_Indexed_Component,
+ N_Identifier,
N_Or_Else,
N_Range,
N_Selected_Component,
@@ -2626,7 +2627,9 @@ package body Sem_Res is
-- replaced by the appropriate call during late
-- expansion.
- if not Box_Present (Elmt) then
+ if Nkind (Elmt) /= N_Iterated_Component_Association
+ and then not Box_Present (Elmt)
+ then
Check_Elmt (Expression (Elmt));
end if;