Commit 84dad556 by Arnaud Charlet

[multiple changes]

2015-05-12  Robert Dewar  <dewar@adacore.com>

	* exp_unst.adb (Get_Real_Subp): New subprogram.
	(Unnest_Subprogram): Use Get_Real_Subp.
	(Uplev_Refs_For_One_Subp): Skip if no ARECnU entity.
	(Uplev_Refs_For_One_Subp): Use actual subtype in unconstrained case.

2015-05-12  Robert Dewar  <dewar@adacore.com>

	* a-reatim.adb ("/"): Add explicit check for Time_Span_First / -1.

2015-05-12  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch4.adb (Extended_Primitive_Ops): New subprogram,
	auxiliary to Try_Primitive_Operation to handle properly prefixed
	calls where the operation is not a primitive of the type, but
	is declared in the package body that is in the immediate scope
	of the type.

From-SVN: r223036
parent ddbc55d8
2015-05-12 Robert Dewar <dewar@adacore.com> 2015-05-12 Robert Dewar <dewar@adacore.com>
* exp_unst.adb (Get_Real_Subp): New subprogram.
(Unnest_Subprogram): Use Get_Real_Subp.
(Uplev_Refs_For_One_Subp): Skip if no ARECnU entity.
(Uplev_Refs_For_One_Subp): Use actual subtype in unconstrained case.
2015-05-12 Robert Dewar <dewar@adacore.com>
* a-reatim.adb ("/"): Add explicit check for Time_Span_First / -1.
2015-05-12 Ed Schonberg <schonberg@adacore.com>
* sem_ch4.adb (Extended_Primitive_Ops): New subprogram,
auxiliary to Try_Primitive_Operation to handle properly prefixed
calls where the operation is not a primitive of the type, but
is declared in the package body that is in the immediate scope
of the type.
2015-05-12 Robert Dewar <dewar@adacore.com>
* sem_util.adb (Is_Variable): Allow X'Deref(Y) as a variable. * sem_util.adb (Is_Variable): Allow X'Deref(Y) as a variable.
2015-05-12 Ed Schonberg <schonberg@adacore.com> 2015-05-12 Ed Schonberg <schonberg@adacore.com>
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2014, AdaCore -- -- Copyright (C) 1995-2015, AdaCore --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -123,6 +123,16 @@ package body Ada.Real_Time is ...@@ -123,6 +123,16 @@ package body Ada.Real_Time is
pragma Unsuppress (Overflow_Check); pragma Unsuppress (Overflow_Check);
pragma Unsuppress (Division_Check); pragma Unsuppress (Division_Check);
begin begin
-- Even though checks are unsuppressed, we need an explicit check for
-- the case of largest negative integer divided by minus one, since
-- some library routines we use fail to catch this case. This will be
-- fixed at the compiler level in the future, at which point this test
-- can be removed.
if Left = Time_Span_First and then Right = -1 then
raise Constraint_Error with "overflow";
end if;
return Time_Span (Duration (Left) / Right); return Time_Span (Duration (Left) / Right);
end "/"; end "/";
......
...@@ -1116,9 +1116,48 @@ package body Exp_Unst is ...@@ -1116,9 +1116,48 @@ package body Exp_Unst is
-- Process uplevel references for one subprogram -- Process uplevel references for one subprogram
declare Uplev_Refs_For_One_Subp : declare
Elmt : Elmt_Id; Elmt : Elmt_Id;
function Get_Real_Subp (Ent : Entity_Id) return Entity_Id;
-- The entity recorded as the enclosing subprogram for the
-- reference sometimes turns out to be a subprogram body.
-- This function gets the proper subprogram spec if needed.
-------------------
-- Get_Real_Subp --
-------------------
function Get_Real_Subp (Ent : Entity_Id) return Entity_Id is
Nod : Node_Id;
begin
-- If we have a subprogram, return it
if Is_Subprogram (Ent) then
return Ent;
-- If we have a subprogram body, go to the body
elsif Ekind (Ent) = E_Subprogram_Body then
Nod := Parent (Parent (Ent));
pragma Assert (Nkind (Nod) = N_Subprogram_Body);
if Acts_As_Spec (Nod) then
return Ent;
else
return Corresponding_Spec (Nod);
end if;
-- Should not be any other possibilities
else
raise Program_Error;
end if;
end Get_Real_Subp;
-- Start of processing for Uplevel_References_For_One_Subp
begin begin
-- Loop through uplevel references -- Loop through uplevel references
...@@ -1127,7 +1166,7 @@ package body Exp_Unst is ...@@ -1127,7 +1166,7 @@ package body Exp_Unst is
-- Rewrite one reference -- Rewrite one reference
declare Rewrite_One_Ref : declare
Ref : constant Node_Id := Actual_Ref (Node (Elmt)); Ref : constant Node_Id := Actual_Ref (Node (Elmt));
-- The reference to be rewritten -- The reference to be rewritten
...@@ -1140,8 +1179,11 @@ package body Exp_Unst is ...@@ -1140,8 +1179,11 @@ package body Exp_Unst is
Typ : constant Entity_Id := Etype (Ent); Typ : constant Entity_Id := Etype (Ent);
-- The type of the referenced entity -- The type of the referenced entity
Atyp : constant Entity_Id := Get_Actual_Subtype (Ref);
-- The actual subtype of the reference
Rsub : constant Entity_Id := Rsub : constant Entity_Id :=
Node (Next_Elmt (Elmt)); Get_Real_Subp (Node (Next_Elmt (Elmt)));
-- The enclosing subprogram for the reference -- The enclosing subprogram for the reference
RSX : constant SI_Type := Subp_Index (Rsub); RSX : constant SI_Type := Subp_Index (Rsub);
...@@ -1155,6 +1197,17 @@ package body Exp_Unst is ...@@ -1155,6 +1197,17 @@ package body Exp_Unst is
SI : SI_Type; SI : SI_Type;
begin begin
-- Ignore if no ARECnF entity for enclosing subprogram
-- which probably happens as a result of not properly
-- treating instance bodies. To be examined ???
-- If this test is omitted, then the compilation of
-- freeze.adb and inline.adb fail in unnesting mode.
if No (STJR.ARECnF) then
goto Continue;
end if;
-- Push the current scope, so that the pointer type -- Push the current scope, so that the pointer type
-- Tnn, and any subsidiary entities resulting from -- Tnn, and any subsidiary entities resulting from
-- the analysis of the rewritten reference, go in the -- the analysis of the rewritten reference, go in the
...@@ -1215,7 +1268,7 @@ package body Exp_Unst is ...@@ -1215,7 +1268,7 @@ package body Exp_Unst is
Rewrite (Ref, Rewrite (Ref,
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc), Prefix => New_Occurrence_Of (Atyp, Loc),
Attribute_Name => Name_Deref, Attribute_Name => Name_Deref,
Expressions => New_List ( Expressions => New_List (
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
...@@ -1240,12 +1293,13 @@ package body Exp_Unst is ...@@ -1240,12 +1293,13 @@ package body Exp_Unst is
Analyze_And_Resolve (Ref, Typ, Suppress => All_Checks); Analyze_And_Resolve (Ref, Typ, Suppress => All_Checks);
Opt.Unnest_Subprogram_Mode := True; Opt.Unnest_Subprogram_Mode := True;
Pop_Scope; Pop_Scope;
end; end Rewrite_One_Ref;
<<Continue>>
Next_Elmt (Elmt); Next_Elmt (Elmt);
Next_Elmt (Elmt); Next_Elmt (Elmt);
end loop; end loop;
end; end Uplev_Refs_For_One_Subp;
end if; end if;
end; end;
end loop Uplev_Refs; end loop Uplev_Refs;
......
...@@ -210,12 +210,12 @@ package body Sem_Ch4 is ...@@ -210,12 +210,12 @@ package body Sem_Ch4 is
(T1, T2 : Entity_Id; (T1, T2 : Entity_Id;
Op_Id : Entity_Id; Op_Id : Entity_Id;
N : Node_Id); N : Node_Id);
-- Subsidiary procedure to Find_Arithmetic_Types. T1 and T2 are valid -- Subsidiary procedure to Find_Arithmetic_Types. T1 and T2 are valid types
-- types for left and right operand. Determine whether they constitute -- for left and right operand. Determine whether they constitute a valid
-- a valid pair for the given operator, and record the corresponding -- pair for the given operator, and record the corresponding interpretation
-- interpretation of the operator node. The node N may be an operator -- of the operator node. The node N may be an operator node (the usual
-- node (the usual case) or a function call whose prefix is an operator -- case) or a function call whose prefix is an operator designator. In
-- designator. In both cases Op_Id is the operator name itself. -- both cases Op_Id is the operator name itself.
procedure Diagnose_Call (N : Node_Id; Nam : Node_Id); procedure Diagnose_Call (N : Node_Id; Nam : Node_Id);
-- Give detailed information on overloaded call where none of the -- Give detailed information on overloaded call where none of the
...@@ -242,6 +242,7 @@ package body Sem_Ch4 is ...@@ -242,6 +242,7 @@ package body Sem_Ch4 is
-- object E. The function returns the designated type of the prefix, taking -- object E. The function returns the designated type of the prefix, taking
-- into account that the designated type of an anonymous access type may be -- into account that the designated type of an anonymous access type may be
-- a limited view, when the non-limited view is visible. -- a limited view, when the non-limited view is visible.
--
-- If in semantics only mode (-gnatc or generic), the function also records -- If in semantics only mode (-gnatc or generic), the function also records
-- that the prefix is a reference to E, if any. Normally, such a reference -- that the prefix is a reference to E, if any. Normally, such a reference
-- is generated only when the implicit dereference is expanded into an -- is generated only when the implicit dereference is expanded into an
...@@ -285,7 +286,7 @@ package body Sem_Ch4 is ...@@ -285,7 +286,7 @@ package body Sem_Ch4 is
-- Ada 2005 (AI-252): Support the object.operation notation. If node N -- Ada 2005 (AI-252): Support the object.operation notation. If node N
-- is a call in this notation, it is transformed into a normal subprogram -- is a call in this notation, it is transformed into a normal subprogram
-- call where the prefix is a parameter, and True is returned. If node -- call where the prefix is a parameter, and True is returned. If node
-- N is not of this form, it is unchanged, and False is returned. if -- N is not of this form, it is unchanged, and False is returned. If
-- CW_Test_Only is true then N is an N_Selected_Component node which -- CW_Test_Only is true then N is an N_Selected_Component node which
-- is part of a call to an entry or procedure of a tagged concurrent -- is part of a call to an entry or procedure of a tagged concurrent
-- type and this routine is invoked to search for class-wide subprograms -- type and this routine is invoked to search for class-wide subprograms
...@@ -315,8 +316,10 @@ package body Sem_Ch4 is ...@@ -315,8 +316,10 @@ package body Sem_Ch4 is
if Is_Overloaded (Opnd) then if Is_Overloaded (Opnd) then
if Nkind (Opnd) in N_Op then if Nkind (Opnd) in N_Op then
Nam := Opnd; Nam := Opnd;
elsif Nkind (Opnd) = N_Function_Call then elsif Nkind (Opnd) = N_Function_Call then
Nam := Name (Opnd); Nam := Name (Opnd);
elsif Ada_Version >= Ada_2012 then elsif Ada_Version >= Ada_2012 then
declare declare
It : Interp; It : Interp;
...@@ -343,7 +346,8 @@ package body Sem_Ch4 is ...@@ -343,7 +346,8 @@ package body Sem_Ch4 is
end if; end if;
if Opnd = Left_Opnd (N) then if Opnd = Left_Opnd (N) then
Error_Msg_N ("\left operand has the following interpretations", N); Error_Msg_N
("\left operand has the following interpretations", N);
else else
Error_Msg_N Error_Msg_N
("\right operand has the following interpretations", N); ("\right operand has the following interpretations", N);
...@@ -606,7 +610,7 @@ package body Sem_Ch4 is ...@@ -606,7 +610,7 @@ package body Sem_Ch4 is
Type_Id := Process_Subtype (E, N); Type_Id := Process_Subtype (E, N);
Acc_Type := Create_Itype (E_Allocator_Type, N); Acc_Type := Create_Itype (E_Allocator_Type, N);
Set_Etype (Acc_Type, Acc_Type); Set_Etype (Acc_Type, Acc_Type);
Set_Directly_Designated_Type (Acc_Type, Type_Id); Set_Directly_Designated_Type (Acc_Type, Type_Id);
Check_Fully_Declared (Type_Id, N); Check_Fully_Declared (Type_Id, N);
...@@ -681,21 +685,21 @@ package body Sem_Ch4 is ...@@ -681,21 +685,21 @@ package body Sem_Ch4 is
else else
Error_Msg_N Error_Msg_N
("uninitialized unconstrained allocation not allowed", ("uninitialized unconstrained allocation not "
N); & "allowed", N);
if Is_Array_Type (Type_Id) then if Is_Array_Type (Type_Id) then
Error_Msg_N Error_Msg_N
("\qualified expression or constraint with " & ("\qualified expression or constraint with "
"array bounds required", N); & "array bounds required", N);
elsif Has_Unknown_Discriminants (Type_Id) then elsif Has_Unknown_Discriminants (Type_Id) then
Error_Msg_N ("\qualified expression required", N); Error_Msg_N ("\qualified expression required", N);
else pragma Assert (Has_Discriminants (Type_Id)); else pragma Assert (Has_Discriminants (Type_Id));
Error_Msg_N Error_Msg_N
("\qualified expression or constraint with " & ("\qualified expression or constraint with "
"discriminant values required", N); & "discriminant values required", N);
end if; end if;
end if; end if;
end if; end if;
...@@ -804,9 +808,9 @@ package body Sem_Ch4 is ...@@ -804,9 +808,9 @@ package body Sem_Ch4 is
-- Entity is not already set, so we do need to collect interpretations -- Entity is not already set, so we do need to collect interpretations
else else
Op_Id := Get_Name_Entity_Id (Chars (N));
Set_Etype (N, Any_Type); Set_Etype (N, Any_Type);
Op_Id := Get_Name_Entity_Id (Chars (N));
while Present (Op_Id) loop while Present (Op_Id) loop
if Ekind (Op_Id) = E_Operator if Ekind (Op_Id) = E_Operator
and then Present (Next_Entity (First_Entity (Op_Id))) and then Present (Next_Entity (First_Entity (Op_Id)))
...@@ -889,6 +893,7 @@ package body Sem_Ch4 is ...@@ -889,6 +893,7 @@ package body Sem_Ch4 is
Actual); Actual);
exit; exit;
end if; end if;
when others => when others =>
Named_Seen := True; Named_Seen := True;
end case; end case;
...@@ -905,10 +910,8 @@ package body Sem_Ch4 is ...@@ -905,10 +910,8 @@ package body Sem_Ch4 is
begin begin
if Is_Entity_Name (Nam) then if Is_Entity_Name (Nam) then
return Ekind (Entity (Nam)) = E_Function; return Ekind (Entity (Nam)) = E_Function;
elsif Nkind (Nam) = N_Selected_Component then elsif Nkind (Nam) = N_Selected_Component then
return Ekind (Entity (Selector_Name (Nam))) = E_Function; return Ekind (Entity (Selector_Name (Nam))) = E_Function;
else else
return False; return False;
end if; end if;
...@@ -932,8 +935,7 @@ package body Sem_Ch4 is ...@@ -932,8 +935,7 @@ package body Sem_Ch4 is
("must instantiate generic procedure& before call", ("must instantiate generic procedure& before call",
Nam, Entity (Nam)); Nam, Entity (Nam));
else else
Error_Msg_N Error_Msg_N ("procedure or entry name expected", Nam);
("procedure or entry name expected", Nam);
end if; end if;
-- Check for tasking cases where only an entry call will do -- Check for tasking cases where only an entry call will do
...@@ -1101,7 +1103,6 @@ package body Sem_Ch4 is ...@@ -1101,7 +1103,6 @@ package body Sem_Ch4 is
end if; end if;
Get_First_Interp (Nam, X, It); Get_First_Interp (Nam, X, It);
while Present (It.Nam) loop while Present (It.Nam) loop
Nam_Ent := It.Nam; Nam_Ent := It.Nam;
Deref := False; Deref := False;
...@@ -1359,7 +1360,6 @@ package body Sem_Ch4 is ...@@ -1359,7 +1360,6 @@ package body Sem_Ch4 is
if No (Alt) then if No (Alt) then
Add_One_Interp (N, It.Typ, It.Typ); Add_One_Interp (N, It.Typ, It.Typ);
else else
Wrong_Alt := Alt; Wrong_Alt := Alt;
end if; end if;
...@@ -1685,11 +1685,11 @@ package body Sem_Ch4 is ...@@ -1685,11 +1685,11 @@ package body Sem_Ch4 is
end loop; end loop;
end if; end if;
-- If there was no match, and the operator is inequality, this may -- If there was no match, and the operator is inequality, this may be
-- be a case where inequality has not been made explicit, as for -- a case where inequality has not been made explicit, as for tagged
-- tagged types. Analyze the node as the negation of an equality -- types. Analyze the node as the negation of an equality operation.
-- operation. This cannot be done earlier, because before analysis -- This cannot be done earlier, because before analysis we cannot rule
-- we cannot rule out the presence of an explicit inequality. -- out the presence of an explicit inequality.
if Etype (N) = Any_Type if Etype (N) = Any_Type
and then Nkind (N) = N_Op_Ne and then Nkind (N) = N_Op_Ne
...@@ -8060,6 +8060,15 @@ package body Sem_Ch4 is ...@@ -8060,6 +8060,15 @@ package body Sem_Ch4 is
-- subprogram because that list starts with the subprogram formals. -- subprogram because that list starts with the subprogram formals.
-- We retrieve the candidate operations from the generic declaration. -- We retrieve the candidate operations from the generic declaration.
function Extended_Primitive_Ops (T : Entity_Id) return Elist_Id;
-- Prefix notation can also be used on operations that are not
-- primitives of the type, but are declared in the same immediate
-- declarative part, which can only mean the corresponding package
-- body (See RM 4.1.3 (9.2/3)). If we are in that body we extend the
-- list of primitives with body operations with the same name that
-- may be candidates, so that Try_Primitive_Operations can examine
-- them if no real primitive is found.
function Is_Private_Overriding (Op : Entity_Id) return Boolean; function Is_Private_Overriding (Op : Entity_Id) return Boolean;
-- An operation that overrides an inherited operation in the private -- An operation that overrides an inherited operation in the private
-- part of its package may be hidden, but if the inherited operation -- part of its package may be hidden, but if the inherited operation
...@@ -8166,6 +8175,61 @@ package body Sem_Ch4 is ...@@ -8166,6 +8175,61 @@ package body Sem_Ch4 is
end if; end if;
end Collect_Generic_Type_Ops; end Collect_Generic_Type_Ops;
----------------------------
-- Extended_Primitive_Ops --
----------------------------
function Extended_Primitive_Ops (T : Entity_Id) return Elist_Id is
Type_Scope : constant Entity_Id := Scope (T);
Body_Decls : List_Id;
Op_Found : Boolean;
Op : Entity_Id;
Op_List : Elist_Id;
begin
Op_List := Primitive_Operations (T);
if Ekind (Type_Scope) = E_Package
and then In_Package_Body (Type_Scope)
and then In_Open_Scopes (Type_Scope)
then
-- Retrieve list of declarations of package body.
Body_Decls :=
Declarations
(Unit_Declaration_Node
(Corresponding_Body
(Unit_Declaration_Node (Type_Scope))));
Op := Current_Entity (Subprog);
Op_Found := False;
while Present (Op) loop
if Comes_From_Source (Op)
and then Is_Overloadable (Op)
and then Is_List_Member (Unit_Declaration_Node (Op))
and then List_Containing (Unit_Declaration_Node (Op)) =
Body_Decls
then
if not Op_Found then
-- Copy list of primitives so it is not affected for
-- other uses.
Op_List := New_Copy_Elist (Op_List);
Op_Found := True;
end if;
Append_Elmt (Op, Op_List);
end if;
Op := Homonym (Op);
end loop;
end if;
return Op_List;
end Extended_Primitive_Ops;
--------------------------- ---------------------------
-- Is_Private_Overriding -- -- Is_Private_Overriding --
--------------------------- ---------------------------
...@@ -8237,7 +8301,7 @@ package body Sem_Ch4 is ...@@ -8237,7 +8301,7 @@ package body Sem_Ch4 is
elsif not Is_Generic_Type (Obj_Type) then elsif not Is_Generic_Type (Obj_Type) then
Corr_Type := Obj_Type; Corr_Type := Obj_Type;
Elmt := First_Elmt (Primitive_Operations (Obj_Type)); Elmt := First_Elmt (Extended_Primitive_Ops (Obj_Type));
else else
Corr_Type := Obj_Type; Corr_Type := Obj_Type;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment