+2017-09-08 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_spark.adb (Expand_SPARK_N_Object_Renaming_Declaration):
+ Reimplemented.
+ (Expand_SPARK_Potential_Renaming): Code clean up.
+ * sem_prag.adb (Analyze_Initialization_Item): Add a guard in case
+ the item does not have a proper entity.
+ (Analyze_Input_Item): Add a guard in case the item does not have a
+ proper entity.
+ (Collect_States_And_Objects): Include object renamings in the
+ items being collected.
+ (Resolve_State): Update the documentation of this routine.
+ * sem_util.adb (Entity_Of): Add circuitry to handle
+ renamings of function results.
+ (Remove_Entity): New routine.
+ (Remove_Overloaded_Entity): Take advantage of factorization.
+ * sem_util.ads (Entity_Of): Update the documentation
+ of this routine.
+ (Remove_Entity): New routine.
+ (Remove_Overloaded_Entity): Update the documentation of this
+ routine.
+
+2017-09-08 Eric Botcazou <ebotcazou@adacore.com>
+
+ * repinfo.adb (List_Record_Info): During first loop,
+ do not override the normalized position and first bit
+ if they have already been set. Move fallback code
+ for the packed case to the case where it belongs.
+ * sem_ch13.adb (Adjust_Record_For_Reverse_Bit_Order):
+ Also adjust the normalized position of components.
+ (Adjust_Record_For_Reverse_Bit_Order_Ada_95): Likewise.
+
+2017-09-08 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_disp.adb (Make_DT, Set_All_DT_Position): Handle properly
+ the placement of a primitive operation O that renames an operation
+ R declared in an inner package, and which is thus not a primitive
+ of the dispatching type of O. In this case O is a new primitive
+ and does not inherit its dispatch table position from R (which
+ has none).
+
+2017-09-08 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_dim.adb (Analyze_Dimension_If_Expression,
+ Analyze_Dimension_Case_Expression): new subprograms to verify
+ the dimensional correctness of Ada2012 conditional expressions,
+ and set properly the dimensions of the construct.
+ * sem_res.adb (Resolve_If_Expression, Resolve_Case_Expression)):
+ call Analyze_Dimension.
+
+2017-09-08 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_type.adb (Expand_Interface_Conversion): Prevent an infinite
+ loop on an interface declared as a private extension of another
+ synchronized interface.
+
2017-09-08 Ed Schonberg <schonberg@adacore.com>
* sem_ch12.adb (Check_Generic_Parent): New procedure within
-- handling of renamings and eliminated primitives.
E := Ultimate_Alias (Prim);
+
+ -- If the alias is not a primitive operation then Prim does
+ -- not rename another primitive, but rather an operation
+ -- declared elsewhere (e.g. in another scope) and therefore
+ -- Prim is a new primitive.
+
+ if No (Find_Dispatching_Type (E)) then
+ E := Prim;
+ end if;
+
Prim_Pos := UI_To_Int (DT_Position (E));
-- Skip predefined primitives because they are located in a
Set_DT_Position_Value (Alias (Prim), DT_Position (E));
Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
- -- Overriding primitives must use the same entry as the
- -- overridden primitive.
+ -- Overriding primitives must use the same entry as the overridden
+ -- primitive. Note that the Alias of the operation is set when the
+ -- operation is declared by a renaming, in which case it is not
+ -- overriding. If it renames another primitive it will use the
+ -- same dispatch table slot, but if it renames an operation in a
+ -- nested package it's a new primitive and will have its own slot.
elsif not Present (Interface_Alias (Prim))
and then Present (Alias (Prim))
and then Chars (Prim) = Chars (Alias (Prim))
- and then Find_Dispatching_Type (Alias (Prim)) /= Typ
- and then Is_Ancestor
- (Find_Dispatching_Type (Alias (Prim)), Typ,
- Use_Full_View => True)
- and then Present (DTC_Entity (Alias (Prim)))
+ and then Nkind (Unit_Declaration_Node (Prim)) /=
+ N_Subprogram_Renaming_Declaration
then
- E := Alias (Prim);
- Set_DT_Position_Value (Prim, DT_Position (E));
+ declare
+ Par_Type : constant Entity_Id :=
+ Find_Dispatching_Type (Alias (Prim));
+ begin
+ if Present (Par_Type)
+ and then Par_Type /= Typ
+ and then Is_Ancestor (Par_Type, Typ, Use_Full_View => True)
+ and then Present (DTC_Entity (Alias (Prim)))
+ then
+ E := Alias (Prim);
+ Set_DT_Position_Value (Prim, DT_Position (E));
- if not Is_Predefined_Dispatching_Alias (E) then
- Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
- end if;
+ if not Is_Predefined_Dispatching_Alias (E) then
+ Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
+ end if;
+ end if;
+ end;
end if;
Next_Elmt (Prim_Elmt);
------------------------------------------------
procedure Expand_SPARK_N_Object_Renaming_Declaration (N : Node_Id) is
+ CFS : constant Boolean := Comes_From_Source (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Obj_Id : constant Entity_Id := Defining_Entity (N);
+ Nam : constant Node_Id := Name (N);
+ Typ : constant Entity_Id := Etype (Subtype_Mark (N));
+
begin
- -- Unconditionally remove all side effects from the name
+ -- Transform a renaming of the form
+
+ -- Obj_Id : <subtype mark> renames <function call>;
+
+ -- into
+
+ -- Obj_Id : constant <subtype mark> := <function call>;
+
+ -- Invoking Evaluate_Name and ultimately Remove_Side_Effects introduces
+ -- a temporary to capture the function result. Once potential renamings
+ -- are rewritten for SPARK, the temporary may be leaked out into source
+ -- constructs and lead to confusing error diagnostics. Using an object
+ -- declaration prevents this unwanted side effect.
+
+ if Nkind (Nam) = N_Function_Call then
+ Rewrite (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Obj_Id,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
+ Expression => Nam));
+
+ -- Inherit the original Comes_From_Source status of the renaming
- Evaluate_Name (Name (N));
+ Set_Comes_From_Source (N, CFS);
+
+ -- Sever the link to the renamed function result because the entity
+ -- will no longer alias anything.
+
+ Set_Renamed_Object (Obj_Id, Empty);
+
+ -- Remove the entity of the renaming declaration from visibility as
+ -- the analysis of the object declaration will reintroduce it again.
+
+ Remove_Entity (Obj_Id);
+ Analyze (N);
+
+ -- Otherwise unconditionally remove all side effects from the name
+
+ else
+ Evaluate_Name (Nam);
+ end if;
end Expand_SPARK_N_Object_Renaming_Declaration;
------------------------
procedure Expand_SPARK_Potential_Renaming (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Ren_Id : constant Entity_Id := Entity (N);
+ Obj_Id : constant Entity_Id := Entity (N);
Typ : constant Entity_Id := Etype (N);
- Obj_Id : Node_Id;
+ Ren : Node_Id;
begin
-- Replace a reference to a renaming with the actual renamed object
- if Ekind (Ren_Id) in Object_Kind then
- Obj_Id := Renamed_Object (Ren_Id);
+ if Ekind (Obj_Id) in Object_Kind then
+ Ren := Renamed_Object (Obj_Id);
- if Present (Obj_Id) then
+ if Present (Ren) then
- -- The renamed object is an entity when instantiating generics
- -- or inlining bodies. In this case the renaming is part of the
- -- mapping "prologue" which links actuals to formals.
+ -- Instantiations and inlining of subprograms employ "prologues"
+ -- which map actual to formal parameters by means of renamings.
+ -- Replace a reference to a formal by the corresponding actual
+ -- parameter.
- if Nkind (Obj_Id) in N_Entity then
- Rewrite (N, New_Occurrence_Of (Obj_Id, Loc));
+ if Nkind (Ren) in N_Entity then
+ Rewrite (N, New_Occurrence_Of (Ren, Loc));
-- Otherwise the renamed object denotes a name
else
- Rewrite (N, New_Copy_Tree (Obj_Id, New_Sloc => Loc));
+ Rewrite (N, New_Copy_Tree (Ren, New_Sloc => Loc));
Reset_Analyzed_Flags (N);
end if;
Cfbit := Component_Bit_Offset (Comp);
if Rep_Not_Constant (Cfbit) then
- UI_Image_Length := 2;
+ -- If the record is not packed, then we know that all fields
+ -- whose position is not specified have a starting normalized
+ -- bit position of zero.
+ if Unknown_Normalized_First_Bit (Comp)
+ and then not Is_Packed (Ent)
+ then
+ Set_Normalized_First_Bit (Comp, Uint_0);
+ end if;
+
+ UI_Image_Length := 2; -- For "??" marker
else
-- Complete annotation in case not done
- Set_Normalized_Position (Comp, Cfbit / SSU);
- Set_Normalized_First_Bit (Comp, Cfbit mod SSU);
+ if Unknown_Normalized_First_Bit (Comp) then
+ Set_Normalized_Position (Comp, Cfbit / SSU);
+ Set_Normalized_First_Bit (Comp, Cfbit mod SSU);
+ end if;
Sunit := Cfbit / SSU;
UI_Image (Sunit);
end if;
- -- If the record is not packed, then we know that all fields
- -- whose position is not specified have a starting normalized
- -- bit position of zero.
-
- if Unknown_Normalized_First_Bit (Comp)
- and then not Is_Packed (Ent)
- then
- Set_Normalized_First_Bit (Comp, Uint_0);
- end if;
-
- Max_Suni_Length :=
- Natural'Max (Max_Suni_Length, UI_Image_Length);
+ Max_Suni_Length := Natural'Max (Max_Suni_Length, UI_Image_Length);
end if;
Next_Component_Or_Discriminant (Comp);
end if;
Set_Component_Bit_Offset (Comp, Pos * SSU + NFB);
+ Set_Normalized_Position (Comp, Pos + NFB / SSU);
Set_Normalized_First_Bit (Comp, NFB mod SSU);
end;
end loop;
(System_Storage_Unit - 1) -
(Start_Bit + CSZ - 1));
+ Set_Normalized_Position (Comp,
+ Component_Bit_Offset (Comp) / System_Storage_Unit);
+
Set_Normalized_First_Bit (Comp,
Component_Bit_Offset (Comp) mod System_Storage_Unit);
end if;
OK_For_Dimension : constant array (Node_Kind) of Boolean :=
(N_Attribute_Reference => True,
+ N_Case_Expression => True,
+ N_If_Expression => True,
N_Expanded_Name => True,
N_Explicit_Dereference => True,
N_Defining_Identifier => True,
-- N_Type_Conversion
-- N_Unchecked_Type_Conversion
+ procedure Analyze_Dimension_Case_Expression (N : Node_Id);
+ -- Verify that all alternatives have the same dimension
+
+ procedure Analyze_Dimension_If_Expression (N : Node_Id);
+ -- Verify that all alternatives have the same dimension
+
procedure Analyze_Dimension_Number_Declaration (N : Node_Id);
-- Procedure to analyze dimension of expression in a number declaration.
-- This allows a named number to have nontrivial dimensions, while by
=>
Analyze_Dimension_Has_Etype (N);
+ when N_Case_Expression =>
+ Analyze_Dimension_Case_Expression (N);
+
+ when N_If_Expression =>
+ Analyze_Dimension_If_Expression (N);
+
-- In the presence of a repaired syntax error, an identifier
-- may be introduced without a usable type.
end if;
end Analyze_Dimension_Call;
+ ---------------------------------------
+ -- Analyze_Dimension_Case_Expression --
+ ---------------------------------------
+
+ procedure Analyze_Dimension_Case_Expression (N : Node_Id) is
+ Alt : Node_Id;
+ Frst : constant Node_Id := First (Alternatives (N));
+ Dims : constant Dimension_Type := Dimensions_Of (Expression (Frst));
+ begin
+ Alt := Next (Frst);
+ while Present (Alt) loop
+ if Dimensions_Of (Expression (Alt)) /= Dims then
+ Error_Msg_N ("dimension mismatch in case expression", Alt);
+ exit;
+ end if;
+
+ Next (Alt);
+ end loop;
+ Copy_Dimensions (Expression (Frst), N);
+ end Analyze_Dimension_Case_Expression;
+
---------------------------------------------
-- Analyze_Dimension_Component_Declaration --
---------------------------------------------
end case;
end Analyze_Dimension_Has_Etype;
+ -------------------------------------
+ -- Analyze_Dimension_If_Expression --
+ -------------------------------------
+
+ procedure Analyze_Dimension_If_Expression (N : Node_Id) is
+ Then_Expr : constant Node_Id := Next (First (Expressions (N)));
+ Else_Expr : constant Node_Id := Next (Then_Expr);
+ begin
+ if Dimensions_Of (Then_Expr) /= Dimensions_Of (Else_Expr) then
+ Error_Msg_N ("dimensions mismatch in conditional expression", N);
+ else
+ Copy_Dimensions (Then_Expr, N);
+ end if;
+ end Analyze_Dimension_If_Expression;
+
------------------------------------------
-- Analyze_Dimension_Number_Declaration --
------------------------------------------
-- reference for future checks (see Analyze_Refined_State_In_Decls).
procedure Resolve_State (N : Node_Id);
- -- Handle the overloading of state names by parameterless functions. When N
- -- denotes a function, this routine finds the corresponding state and sets
- -- the entity of N to that of the state.
+ -- Handle the overloading of state names by functions. When N denotes a
+ -- function, this routine finds the corresponding state and sets the entity
+ -- of N to that of the state.
procedure Rewrite_Assertion_Kind
(N : Node_Id;
if Is_Entity_Name (Item) then
Item_Id := Entity_Of (Item);
- if Ekind_In (Item_Id, E_Abstract_State,
- E_Constant,
- E_Variable)
+ if Present (Item_Id)
+ and then Ekind_In (Item_Id, E_Abstract_State,
+ E_Constant,
+ E_Variable)
then
-- The state or variable must be declared in the visible
-- declarations of the package (SPARK RM 7.1.5(7)).
if Is_Entity_Name (Input) then
Input_Id := Entity_Of (Input);
- if Ekind_In (Input_Id, E_Abstract_State,
- E_Constant,
- E_Generic_In_Out_Parameter,
- E_Generic_In_Parameter,
- E_In_Parameter,
- E_In_Out_Parameter,
- E_Out_Parameter,
- E_Variable)
+ if Present (Input_Id)
+ and then Ekind_In (Input_Id, E_Abstract_State,
+ E_Constant,
+ E_Generic_In_Out_Parameter,
+ E_Generic_In_Parameter,
+ E_In_Parameter,
+ E_In_Out_Parameter,
+ E_Out_Parameter,
+ E_Variable)
then
-- The input cannot denote states or objects declared
-- within the related package (SPARK RM 7.1.5(4)).
Decl := First (Visible_Declarations (Pack_Spec));
while Present (Decl) loop
if Comes_From_Source (Decl)
- and then Nkind (Decl) = N_Object_Declaration
+ and then Nkind_In (Decl, N_Object_Declaration,
+ N_Object_Renaming_Declaration)
then
Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
Set_Etype (N, Typ);
Eval_Case_Expression (N);
+ Analyze_Dimension (N);
end Resolve_Case_Expression;
-------------------------------
if not Error_Posted (N) then
Eval_If_Expression (N);
end if;
+
+ Analyze_Dimension (N);
end Resolve_If_Expression;
-------------------------------
-- Continue climbing
else
- -- Use the full-view of private types (if allowed)
+ -- Use the full-view of private types (if allowed).
+ -- Guard against infinite loops when full view has same
+ -- type as parent, as can happen with interface extensions,
if Use_Full_View
and then Is_Private_Type (Par)
and then Present (Full_View (Par))
+ and then Par /= Etype (Full_View (Par))
then
Par := Etype (Full_View (Par));
else
---------------
function Entity_Of (N : Node_Id) return Entity_Id is
- Id : Entity_Id;
+ Id : Entity_Id;
+ Ren : Node_Id;
begin
+ -- Assume that the arbitrary node does not have an entity
+
Id := Empty;
if Is_Entity_Name (N) then
Id := Entity (N);
- -- Follow a possible chain of renamings to reach the root renamed
- -- object.
+ -- Follow a possible chain of renamings to reach the earliest renamed
+ -- source object.
while Present (Id)
and then Is_Object (Id)
and then Present (Renamed_Object (Id))
loop
- if Is_Entity_Name (Renamed_Object (Id)) then
- Id := Entity (Renamed_Object (Id));
+ Ren := Renamed_Object (Id);
+
+ -- The reference renames an abstract state or a whole object
+
+ -- Obj : ...;
+ -- Ren : ... renames Obj;
+
+ if Is_Entity_Name (Ren) then
+ Id := Entity (Ren);
+
+ -- The reference renames a function result. Check the original
+ -- node in case expansion relocates the function call.
+
+ -- Ren : ... renames Func_Call;
+
+ elsif Nkind (Original_Node (Ren)) = N_Function_Call then
+ exit;
+
+ -- Otherwise the reference renames something which does not yield
+ -- an abstract state or a whole object. Treat the reference as not
+ -- having a proper entity for SPARK legality purposes.
+
else
Id := Empty;
exit;
end if;
end References_Generic_Formal_Type;
+ -------------------
+ -- Remove_Entity --
+ -------------------
+
+ procedure Remove_Entity (Id : Entity_Id) is
+ Scop : constant Entity_Id := Scope (Id);
+ Prev_Id : Entity_Id;
+
+ begin
+ -- Remove the entity from the homonym chain. When the entity is the
+ -- head of the chain, associate the entry in the name table with its
+ -- homonym effectively making it the new head of the chain.
+
+ if Current_Entity (Id) = Id then
+ Set_Name_Entity_Id (Chars (Id), Homonym (Id));
+
+ -- Otherwise link the previous and next homonyms
+
+ else
+ Prev_Id := Current_Entity (Id);
+ while Present (Prev_Id) and then Homonym (Prev_Id) /= Id loop
+ Prev_Id := Homonym (Prev_Id);
+ end loop;
+
+ Set_Homonym (Prev_Id, Homonym (Id));
+ end if;
+
+ -- Remove the entity from the scope entity chain. When the entity is
+ -- the head of the chain, set the next entity as the new head of the
+ -- chain.
+
+ if First_Entity (Scop) = Id then
+ Prev_Id := Empty;
+ Set_First_Entity (Scop, Next_Entity (Id));
+
+ -- Otherwise the entity is either in the middle of the chain or it acts
+ -- as its tail. Traverse and link the previous and next entities.
+
+ else
+ Prev_Id := First_Entity (Scop);
+ while Present (Prev_Id) and then Next_Entity (Prev_Id) /= Id loop
+ Next_Entity (Prev_Id);
+ end loop;
+
+ Set_Next_Entity (Prev_Id, Next_Entity (Id));
+ end if;
+
+ -- Handle the case where the entity acts as the tail of the scope entity
+ -- chain.
+
+ if Last_Entity (Scop) = Id then
+ Set_Last_Entity (Scop, Prev_Id);
+ end if;
+ end Remove_Entity;
+
--------------------
-- Remove_Homonym --
--------------------
-- Local variables
- Scop : constant Entity_Id := Scope (Id);
- Formal : Entity_Id;
- Prev_Id : Entity_Id;
+ Formal : Entity_Id;
-- Start of processing for Remove_Overloaded_Entity
begin
- -- Remove the entity from the homonym chain. When the entity is the
- -- head of the chain, associate the entry in the name table with its
- -- homonym effectively making it the new head of the chain.
-
- if Current_Entity (Id) = Id then
- Set_Name_Entity_Id (Chars (Id), Homonym (Id));
-
- -- Otherwise link the previous and next homonyms
-
- else
- Prev_Id := Current_Entity (Id);
- while Present (Prev_Id) and then Homonym (Prev_Id) /= Id loop
- Prev_Id := Homonym (Prev_Id);
- end loop;
-
- Set_Homonym (Prev_Id, Homonym (Id));
- end if;
-
- -- Remove the entity from the scope entity chain. When the entity is
- -- the head of the chain, set the next entity as the new head of the
- -- chain.
-
- if First_Entity (Scop) = Id then
- Prev_Id := Empty;
- Set_First_Entity (Scop, Next_Entity (Id));
+ -- Remove the entity from both the homonym and scope chains
- -- Otherwise the entity is either in the middle of the chain or it acts
- -- as its tail. Traverse and link the previous and next entities.
-
- else
- Prev_Id := First_Entity (Scop);
- while Present (Prev_Id) and then Next_Entity (Prev_Id) /= Id loop
- Next_Entity (Prev_Id);
- end loop;
-
- Set_Next_Entity (Prev_Id, Next_Entity (Id));
- end if;
-
- -- Handle the case where the entity acts as the tail of the scope entity
- -- chain.
-
- if Last_Entity (Scop) = Id then
- Set_Last_Entity (Scop, Prev_Id);
- end if;
+ Remove_Entity (Id);
-- The entity denotes a primitive subprogram. Remove it from the list of
-- primitives of the associated controlling type.
-- are entered using Sem_Ch6.Enter_Overloadable_Entity.
function Entity_Of (N : Node_Id) return Entity_Id;
- -- Return the entity of N or Empty. If N is a renaming, return the entity
- -- of the root renamed object.
+ -- Obtain the entity of arbitrary node N. If N is a renaming, return the
+ -- entity of the earliest renamed source abstract state or whole object.
+ -- If no suitable entity is available, return Empty.
procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id);
-- This procedure is called after issuing a message complaining about an
-- Returns True if the expression Expr contains any references to a generic
-- type. This can only happen within a generic template.
+ procedure Remove_Entity (Id : Entity_Id);
+ -- Remove arbitrary entity Id from both the homonym and scope chains. Use
+ -- Remove_Overloaded_Entity for overloadable entities. Note: the removal
+ -- performed by this routine does not affect the visibility of existing
+ -- homonyms.
+
procedure Remove_Homonym (E : Entity_Id);
-- Removes E from the homonym chain
procedure Remove_Overloaded_Entity (Id : Entity_Id);
-- Remove arbitrary entity Id from the homonym chain, the scope chain and
- -- the primitive operations list of the associated controlling type. NOTE:
- -- the removal performed by this routine does not affect the visibility of
- -- existing homonyms.
+ -- the primitive operations list of the associated controlling type. Use
+ -- Remove_Entity for non-overloadable entities. Note: the removal performed
+ -- by this routine does not affect the visibility of existing homonyms.
function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id;
-- Returns the name of E without Suffix
projects / platform / upstream / gcc.git / commitdiff