+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
-- --
-- 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- --
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 --
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));
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));
-- --
-- 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 --
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";
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;
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);
("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);
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);
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);
-- 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
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
-- 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.
-- 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;
-- 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);
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);
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);
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);
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
N_Attribute_Reference,
N_And_Then,
N_Indexed_Component,
+ N_Identifier,
N_Or_Else,
N_Range,
N_Selected_Component,
-- 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;
projects / gcc.git / commitdiff