+2018-08-21 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * checks.adb, contracts.adb, exp_aggr.adb, exp_attr.adb,
+ exp_ch6.adb, exp_ch7.adb, exp_ch9.adb, exp_unst.adb,
+ exp_util.adb, freeze.adb, gnatlink.adb, layout.adb,
+ lib-writ.adb, lib-xref-spark_specific.adb, sem_ch13.adb,
+ sem_ch3.adb, sem_ch6.adb, sem_res.adb, sem_util.adb, sinfo.ads,
+ sprint.adb: Minor reformatting.
+
2018-08-21 Jerome Lambourg <lambourg@adacore.com>
* vxlink-bind.adb, vxlink-bind.ads, vxlink-link.adb,
and then Is_Integer_Type (Target_Base_Type)
then
Conv_Node :=
- OK_Convert_To (
- Typ => Target_Base_Type,
- Expr => Duplicate_Subexpr (N));
+ OK_Convert_To
+ (Typ => Target_Base_Type,
+ Expr => Duplicate_Subexpr (N));
-- Common case
null;
-- Otherwise analyze the pre/postconditions. Their expressions
- -- might include references to types that are not frozen yet,
- -- in the case where the body is a rewritten expression function
- -- that is a completion, so freeze all types within before
- -- constructing the contract code.
+ -- might include references to types that are not frozen yet, in the
+ -- case where the body is a rewritten expression function that is a
+ -- completion, so freeze all types within before constructing the
+ -- contract code.
else
declare
- Bod : Node_Id;
+ Bod : Node_Id;
Freeze_Types : Boolean := False;
+
begin
if Present (Freeze_Id) then
Bod := Unit_Declaration_Node (Freeze_Id);
+
if Nkind (Bod) = N_Subprogram_Body
and then Was_Expression_Function (Bod)
and then Ekind (Subp_Id) = E_Function
Prag := Pre_Post_Conditions (Items);
while Present (Prag) loop
if Freeze_Types then
- Freeze_Expr_Types (Subp_Id, Standard_Boolean,
- Expression (Corresponding_Aspect (Prag)), Bod);
+ Freeze_Expr_Types
+ (Def_Id => Subp_Id,
+ Typ => Standard_Boolean,
+ Expr => Expression (Corresponding_Aspect (Prag)),
+ N => Bod);
end if;
Analyze_Pre_Post_Condition_In_Decl_Part (Prag, Freeze_Id);
Establish_Transient_Scope (N, Manage_Sec_Stack => False);
end if;
- -- An array of limited components is built in place.
+ -- An array of limited components is built in place
if Is_Limited_Type (Typ) then
Maybe_In_Place_OK := True;
-- oversight: the rules in 7.6 (17) are clear.
if (not Has_Default_Init_Comps (N)
- or else Is_Limited_Type (Etype (N)))
+ or else Is_Limited_Type (Etype (N)))
and then Comes_From_Source (Parent_Node)
and then Parent_Kind = N_Object_Declaration
and then Present (Expression (Parent_Node))
if Has_Default_Init_Comps (N)
and then not Maybe_In_Place_OK
then
-
-- Ada 2005 (AI-287): This case has not been analyzed???
raise Program_Error;
if Is_Fixed_Point_Type (Etype (N)) then
declare
Loc : constant Source_Ptr := Sloc (N);
- Equiv_T : constant Entity_Id := Make_Temporary (Loc, 'T', N);
- Expr : constant Node_Id := Expression (N);
- Fst : constant Entity_Id := Root_Type (Etype (N));
+ Equiv_T : constant Entity_Id := Make_Temporary (Loc, 'T', N);
+ Expr : constant Node_Id := Expression (N);
+ Fst : constant Entity_Id := Root_Type (Etype (N));
Decl : Node_Id;
begin
- Decl := Make_Full_Type_Declaration (Sloc (N),
- Equiv_T,
- Type_Definition =>
- Make_Signed_Integer_Type_Definition (Loc,
- Low_Bound => Make_Integer_Literal (Loc,
- Intval => Corresponding_Integer_Value
- (Type_Low_Bound (Fst))),
- High_Bound => Make_Integer_Literal (Loc,
- Intval => Corresponding_Integer_Value
- (Type_High_Bound (Fst)))));
+ Decl :=
+ Make_Full_Type_Declaration (Sloc (N),
+ Defining_Identifier => Equiv_T,
+ Type_Definition =>
+ Make_Signed_Integer_Type_Definition (Loc,
+ Low_Bound =>
+ Make_Integer_Literal (Loc,
+ Intval =>
+ Corresponding_Integer_Value
+ (Type_Low_Bound (Fst))),
+ High_Bound =>
+ Make_Integer_Literal (Loc,
+ Intval =>
+ Corresponding_Integer_Value
+ (Type_High_Bound (Fst)))));
Insert_Action (N, Decl);
- -- Verify that the conversion is possible.
- Generate_Range_Check
- (Expr, Equiv_T, CE_Overflow_Check_Failed);
+ -- Verify that the conversion is possible
+
+ Generate_Range_Check (Expr, Equiv_T, CE_Overflow_Check_Failed);
+
+ -- and verify that the result is in range
- -- and verify that the result is in range.
Generate_Range_Check (N, Etype (N), CE_Range_Check_Failed);
end;
end if;
and then Is_Protected_Type (Etype (Prefix (Name (Parent (N)))))
and then Is_Entity_Name (Name (N))
and then Scope (Entity (Name (N))) =
- Etype (Prefix (Name (Parent (N))))
+ Etype (Prefix (Name (Parent (N))))
then
Rewrite (Name (N),
Make_Selected_Component (Sloc (N),
- Prefix => New_Copy_Tree (Prefix (Name (Parent (N)))),
+ Prefix => New_Copy_Tree (Prefix (Name (Parent (N)))),
Selector_Name => Relocate_Node (Name (N))));
+
Analyze_And_Resolve (N);
return;
-----------------------
function First_Local_Scope (L : List_Id) return Entity_Id is
- Stat : Node_Id;
Scop : Entity_Id;
+ Stat : Node_Id;
begin
Stat := First (L);
when others =>
null;
end case;
+
Next (Stat);
end loop;
and then Present (Handled_Statement_Sequence (N))
and then Is_Compilation_Unit (Current_Scope)
then
- Ent := First_Local_Scope
- (Statements (Handled_Statement_Sequence (N)));
+ Ent :=
+ First_Local_Scope (Statements (Handled_Statement_Sequence (N)));
if Present (Ent) then
Elab_Proc :=
end if;
Analyze (N);
+
Reset_Scopes_To (N, Entity (Identifier (N)));
end Expand_N_Conditional_Entry_Call;
Make_Defining_Identifier (Eloc,
New_External_Name (Chars (Ename), 'A', Num_Accept));
- -- Link the acceptor to the original receiving entry.
+ -- Link the acceptor to the original receiving entry
Set_Ekind (PB_Ent, E_Procedure);
Set_Receiving_Entry (PB_Ent, Eent);
---------------------
procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id) is
-
function Reset_Scope (N : Node_Id) return Traverse_Result;
-- Temporaries may have been declared during expansion of the procedure
-- created for an entry body or an accept alternative. Indicate that
-- Ditto for a package declaration or a full type declaration, etc.
elsif Nkind (N) = N_Package_Declaration
- or else Nkind (N) in N_Declaration
- or else Nkind (N) in N_Renaming_Declaration
+ or else Nkind (N) in N_Declaration
+ or else Nkind (N) in N_Renaming_Declaration
then
Set_Scope (Defining_Entity (N), E);
return Skip;
E := Ultimate_Alias (E);
-- The body of a protected operation has a different name and
- -- has been scanned at this point, and thus has an entry in
- -- the subprogram table.
+ -- has been scanned at this point, and thus has an entry in the
+ -- subprogram table.
- if E = Sub
- and then Convention (E) = Convention_Protected
- then
+ if E = Sub and then Convention (E) = Convention_Protected then
E := Protected_Body_Subprogram (E);
end if;
-- Explicit dereference and selected component case
- elsif Nkind_In (N,
- N_Explicit_Dereference,
- N_Selected_Component)
+ elsif Nkind_In (N, N_Explicit_Dereference,
+ N_Selected_Component)
then
Note_Uplevel_Bound (Prefix (N), Ref);
declare
Align_In_Bits : constant Nat := M * System_Storage_Unit;
- Off : Uint;
- Siz : Uint;
+ Comp : Entity_Id;
+
begin
+ Comp := C;
+
-- For a component inherited in a record extension, the
-- clause is inherited but position and size are not set.
if Is_Base_Type (Etype (P))
and then Is_Tagged_Type (Etype (P))
- and then Present (Original_Record_Component (C))
+ and then Present (Original_Record_Component (Comp))
then
- Off :=
- Component_Bit_Offset (Original_Record_Component (C));
- Siz := Esize (Original_Record_Component (C));
- else
- Off := Component_Bit_Offset (C);
- Siz := Esize (C);
+ Comp := Original_Record_Component (Comp);
end if;
- if Off mod Align_In_Bits /= 0
- or else Siz mod Align_In_Bits /= 0
+ if Component_Bit_Offset (Comp) mod Align_In_Bits /= 0
+ or else Esize (Comp) mod Align_In_Bits /= 0
then
return True;
end if;
if Is_Access_Type (F_Type)
and then Esize (F_Type) > Ttypes.System_Address_Size
and then (not Unnest_Subprogram_Mode
- or else not Is_Access_Subprogram_Type (F_Type))
+ or else not Is_Access_Subprogram_Type (F_Type))
then
Error_Msg_N
("?x?type of & does not correspond to C pointer!", Formal);
Expr : Node_Id;
N : Node_Id)
is
-
function Cloned_Expression return Node_Id;
- -- Build a duplicate of the expression of the return statement that
- -- has no defining entities shared with the original expression.
+ -- Build a duplicate of the expression of the return statement that has
+ -- no defining entities shared with the original expression.
function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result;
-- Freeze all types referenced in the subtree rooted at Node
if Nkind_In (Node, N_Iterator_Specification,
N_Loop_Parameter_Specification)
then
- Set_Defining_Identifier (Node,
- New_Copy (Defining_Identifier (Node)));
+ Set_Defining_Identifier
+ (Node, New_Copy (Defining_Identifier (Node)));
end if;
return OK;
return;
end if;
- -- This provides a better error message than generating
- -- primitives whose compilation fails much later. Refine
- -- the error message if possible.
+ -- This provides a better error message than generating primitives
+ -- whose compilation fails much later. Refine the error message if
+ -- possible.
Check_Fully_Declared (Typ, Node);
Check_And_Freeze_Type (Scope (Entity (Node)));
end if;
- -- Freezing an access type does not freeze the designated type,
- -- but freezing conversions between access to interfaces requires
- -- that the interface types themselves be frozen, so that dispatch
- -- table entities are properly created.
+ -- Freezing an access type does not freeze the designated type, but
+ -- freezing conversions between access to interfaces requires that
+ -- the interface types themselves be frozen, so that dispatch table
+ -- entities are properly created.
-- Unclear whether a more general rule is needed ???
Check_And_Freeze_Type (Designated_Type (Etype (Node)));
end if;
- -- An implicit dereference freezes the designated type. In the
- -- case of a dispatching call whose controlling argument is an
- -- access type, the dereference is not made explicit, so we must
- -- check for such a call and freeze the designated type.
+ -- An implicit dereference freezes the designated type. In the case
+ -- of a dispatching call whose controlling argument is an access
+ -- type, the dereference is not made explicit, so we must check for
+ -- such a call and freeze the designated type.
if Nkind (Node) in N_Has_Etype
and then Present (Etype (Node))
-- as it is in the same directory as the shared version.
if Nlast >= Library_Version'Length
- and then Next_Line
- (Nlast - Library_Version'Length + 1 .. Nlast)
- = Library_Version
+ and then
+ Next_Line (Nlast - Library_Version'Length + 1 .. Nlast) =
+ Library_Version
then
-- Set Last to point to last character before the
-- library version.
Init_Size (E, 2 * System_Address_Size);
-- If unnesting subprograms, subprogram access types contain the
- -- address of both the subprogram and an activation record. But
- -- if we set that, we'll get a warning on different unchecked
- -- conversion sizes in the RTS. So leave unset ub that case.
+ -- address of both the subprogram and an activation record. But if we
+ -- set that, we'll get a warning on different unchecked conversion
+ -- sizes in the RTS. So leave unset ub that case.
elsif Unnest_Subprogram_Mode
and then Is_Access_Subprogram_Type (E)
then
- -- Init_Size (E, 2 * System_Address_Size);
null;
-- Normal case of thin pointer
-- allow partial analysis on incomplete sources.
if GNATprove_Mode then
-
Body_Fname :=
- Get_File_Name (Get_Body_Name (Uname),
- Subunit => False, May_Fail => True);
+ Get_File_Name
+ (Uname => Get_Body_Name (Uname),
+ Subunit => False,
+ May_Fail => True);
Body_Index := Get_Unit_Index (Get_Body_Name (Uname));
else
Body_Fname :=
- Get_File_Name (Get_Body_Name (Uname),
- Subunit => False, May_Fail => False);
+ Get_File_Name
+ (Uname => Get_Body_Name (Uname),
+ Subunit => False,
+ May_Fail => False);
Body_Index := Get_Unit_Index (Get_Body_Name (Uname));
end if;
end loop;
if Nkind (Context) = N_Pragma then
+
-- When used for cross-references then aspects might not be
-- yet linked to pragmas; when used for AST navigation in
-- GNATprove this routine is expected to follow those links.
-- Case where predicates are present
if Present (Expr) then
+
-- Test for raise expression present
Test_REs (Expr);
if Raise_Expression_Present then
declare
- Map : constant Elist_Id := New_Elmt_List;
- New_V : Entity_Id := Empty;
-
- -- The unanalyzed expression will be copied and appear in
- -- both functions. Normally expressions do not declare new
- -- entities, but quantified expressions do, so we need to
- -- create new entities for their bound variables, to prevent
- -- multiple definitions in gigi.
-
- function Reset_Loop_Variable (N : Node_Id)
- return Traverse_Result;
+ function Reset_Loop_Variable
+ (N : Node_Id) return Traverse_Result;
- procedure Collect_Loop_Variables is
+ procedure Reset_Loop_Variables is
new Traverse_Proc (Reset_Loop_Variable);
------------------------
-- Reset_Loop_Variable --
------------------------
- function Reset_Loop_Variable (N : Node_Id)
- return Traverse_Result
+ function Reset_Loop_Variable
+ (N : Node_Id) return Traverse_Result
is
begin
if Nkind (N) = N_Iterator_Specification then
- New_V := Make_Defining_Identifier
- (Sloc (N), Chars (Defining_Identifier (N)));
-
- Set_Defining_Identifier (N, New_V);
+ Set_Defining_Identifier (N,
+ Make_Defining_Identifier
+ (Sloc (N), Chars (Defining_Identifier (N))));
end if;
return OK;
end Reset_Loop_Variable;
+ -- Local variables
+
+ Map : constant Elist_Id := New_Elmt_List;
+
begin
Append_Elmt (Object_Entity, Map);
Append_Elmt (Object_Entity_M, Map);
Expr_M := New_Copy_Tree (Expr, Map => Map);
- Collect_Loop_Variables (Expr_M);
+
+ -- The unanalyzed expression will be copied and appear in
+ -- both functions. Normally expressions do not declare new
+ -- entities, but quantified expressions do, so we need to
+ -- create new entities for their bound variables, to prevent
+ -- multiple definitions in gigi.
+
+ Reset_Loop_Variables (Expr_M);
end;
end if;
-- loops during analysis and expansion.
declare
- function Reset_Quantified_Variable_Scope (N : Node_Id)
- return Traverse_Result;
+ function Reset_Quantified_Variable_Scope
+ (N : Node_Id) return Traverse_Result;
procedure Reset_Quantified_Variables_Scope is
new Traverse_Proc (Reset_Quantified_Variable_Scope);
-- Reset_Quantified_Variable_Scope --
-------------------------------------
- function Reset_Quantified_Variable_Scope (N : Node_Id)
- return Traverse_Result
+ function Reset_Quantified_Variable_Scope
+ (N : Node_Id) return Traverse_Result
is
begin
if Nkind_In (N, N_Iterator_Specification,
Set_Scope (Defining_Identifier (N),
Predicate_Function (Typ));
end if;
+
return OK;
end Reset_Quantified_Variable_Scope;
Related_Nod : Node_Id) return Entity_Id
is
T_Sub : constant Entity_Id :=
- Create_Itype (E_Record_Subtype,
- Related_Nod, Corr_Rec, 'C', Suffix_Index => -1);
+ Create_Itype
+ (Ekind => E_Record_Subtype,
+ Related_Nod => Related_Nod,
+ Related_Id => Corr_Rec,
+ Suffix => 'C',
+ Suffix_Index => -1);
begin
Set_Etype (T_Sub, Corr_Rec);
-- As elsewhere, we do not emit freeze nodes within a generic unit.
if not Inside_A_Generic then
- Freeze_Expr_Types (Def_Id, Etype (Def_Id), Expr, N);
+ Freeze_Expr_Types
+ (Def_Id => Def_Id,
+ Typ => Etype (Def_Id),
+ Expr => Expr,
+ N => N);
end if;
-- For navigation purposes, indicate that the function is a body
end if;
end;
- -- Functions can override abstract interface functions
- -- Return types must be subtype conformant.
+ -- Functions can override abstract interface functions. Return
+ -- types must be subtype conformant.
elsif Ekind (Def_Id) = E_Function
and then Ekind (Subp) = E_Function
and then Matches_Prefixed_View_Profile
(Parameter_Specifications (Parent (Def_Id)),
Parameter_Specifications (Parent (Subp)))
- and then Conforming_Types (Etype (Def_Id), Etype (Subp),
- Subtype_Conformant)
+ and then Conforming_Types
+ (Etype (Def_Id), Etype (Subp), Subtype_Conformant)
then
Candidate := Subp;
then
if Is_Expression_Function (Entity (Subp)) then
- -- Force freeze of expression function in call.
+ -- Force freeze of expression function in call
Set_Comes_From_Source (Subp, True);
- Set_Must_Not_Freeze (Subp, False);
+ Set_Must_Not_Freeze (Subp, False);
end if;
Freeze_Expression (Subp);
-- For a predefined operator, the type of the result is the type imposed
-- by context, except for a predefined operation on universal fixed.
- -- Otherwise The type of the call is the type returned by the subprogram
+ -- Otherwise the type of the call is the type returned by the subprogram
-- being called.
if Is_Predefined_Op (Nam) then
Ret_Type : constant Entity_Id := Etype (Nam);
begin
- -- If this is a parameterless call there is no ambiguity
- -- and the call has the type of the function.
+ -- If this is a parameterless call there is no ambiguity and the
+ -- call has the type of the function.
if No (First_Actual (N)) then
Set_Etype (N, Etype (Nam));
+
if Present (First_Formal (Nam)) then
Resolve_Actuals (N, Nam);
end if;
+
+ -- Annotate the tree by creating a call marker in case the
+ -- original call is transformed by expansion. The call marker
+ -- is automatically saved for later examination by the ABE
+ -- Processing phase.
+
Build_Call_Marker (N);
elsif Is_Access_Type (Ret_Type)
then
return True;
- -- OUtside of its scope, a synchronized type may just be
- -- private.
+ -- Outside of its scope, a synchronized type may just be private
elsif Is_Private_Type (Curr)
and then Present (Full_View (Curr))
- and then Is_Concurrent_Type (Full_View (Curr))
+ and then Is_Concurrent_Type (Full_View (Curr))
then
return Scope_Within (Full_View (Curr), Outer);
end if;
--------------------------
-- 4.5.7 If Expression --
- ----------------------------
+ --------------------------
-- IF_EXPRESSION ::=
-- if CONDITION then DEPENDENT_EXPRESSION
-- where the aspects are printed inside the package specification.
if Has_Aspects (Node)
- and then not Nkind_In (Node, N_Package_Declaration,
- N_Generic_Package_Declaration)
- and then not Is_Empty_List (Aspect_Specifications (Node))
+ and then not Nkind_In (Node, N_Generic_Package_Declaration,
+ N_Package_Declaration)
and then not Is_Empty_List (Aspect_Specifications (Node))
then
Sprint_Aspect_Specifications (Node, Semicolon => True);
end if;
- if Nkind (Node) in N_Subexpr
- and then Do_Range_Check (Node)
- then
+ if Nkind (Node) in N_Subexpr and then Do_Range_Check (Node) then
Write_Str ("}");
end if;
projects / gcc.git / commitdiff