Skip to content

R
riscv-gcc-1
Commit 1a779058 by Arnaud Charlet
Options

[multiple changes] 

2015-01-06  Thomas Quinot  <quinot@adacore.com>

	* freeze.adb (Set_SSO_From_Defaults): When setting scalar storage
	order to native from default, make sure to also adjust bit order.
	* exp_aggr.adb: Minor reformatting.

2015-01-06  Robert Dewar  <dewar@adacore.com>

	* s-valllu.adb, s-valllu.ads, s-valuti.ads, s-valuns.adb, s-valuns.ads,
	s-valrea.adb, s-valrea.ads: Add some additional guards for
	Str'Last = Positive'Last.

2015-01-06  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch12.adb, sem_ch8.adb: Ongoing work for wrappers for actual
	subprograms.

2015-01-06  Javier Miranda  <miranda@adacore.com>

	* exp_disp.adb (Expand_Interface_Conversion): Reapply patch.

From-SVN: r219250
parent 375cbc2b
Showing with 271 additions and 219 deletions
gcc/ada/ChangeLog
2015-01-06 Thomas Quinot <quinot@adacore.com>
* freeze.adb (Set_SSO_From_Defaults): When setting scalar storage
order to native from default, make sure to also adjust bit order.
* exp_aggr.adb: Minor reformatting.
2015-01-06 Robert Dewar <dewar@adacore.com>
* s-valllu.adb, s-valllu.ads, s-valuti.ads, s-valuns.adb, s-valuns.ads,
s-valrea.adb, s-valrea.ads: Add some additional guards for
Str'Last = Positive'Last.
2015-01-06 Ed Schonberg <schonberg@adacore.com>
* sem_ch12.adb, sem_ch8.adb: Ongoing work for wrappers for actual
subprograms.
2015-01-06 Javier Miranda <miranda@adacore.com>
* exp_disp.adb (Expand_Interface_Conversion): Reapply patch.
2015-01-06 Thomas Quinot <quinot@adacore.com>
* sem_util.ads: Minor reformatting.
* sem_cat.adb (In_RCI_Visible_Declarations): Change back to...
(In_RCI_Declaration) Return to old name, as proper checking of
......
gcc/ada/exp_aggr.adb
......@@ -239,10 +239,10 @@ package body Exp_Aggr is
-- Packed_Array_Aggregate_Handled, we set this parameter to True, since
-- these are cases we handle in there.
-- It would seem worthwhile to have a higher default value for Max_Others_
-- replicate, but aggregates in the compiler make this impossible: the
-- compiler bootstrap fails if Max_Others_Replicate is greater than 25.
-- This is unexpected ???
-- It would seem useful to have a higher default for Max_Others_Replicate,
-- but aggregates in the compiler make this impossible: the compiler
-- bootstrap fails if Max_Others_Replicate is greater than 25. This
-- is unexpected ???
procedure Expand_Array_Aggregate (N : Node_Id);
-- This is the top-level routine to perform array aggregate expansion.
......
gcc/ada/exp_disp.adb
......@@ -1138,6 +1138,25 @@ package body Exp_Disp is
Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
end if;
-- No displacement of the pointer to the object needed when the type of
-- the operand is not an interface type and the interface is one of
-- its parent types (since they share the primary dispatch table).
declare
Opnd : Entity_Id := Operand_Typ;
begin
if Is_Access_Type (Opnd) then
Opnd := Designated_Type (Opnd);
end if;
if not Is_Interface (Opnd)
and then Is_Ancestor (Iface_Typ, Opnd, Use_Full_View => True)
then
return;
end if;
end;
-- Evaluate if we can statically displace the pointer to the object
declare
......
gcc/ada/freeze.adb
......@@ -7748,6 +7748,8 @@ package body Freeze is
--------------------------
procedure Set_SSO_From_Default (T : Entity_Id) is
Reversed : Boolean;
begin
-- Set default SSO for an array or record base type, except in case of
-- a type extension (which always inherits the SSO of its parent type).
......@@ -7758,31 +7760,35 @@ package body Freeze is
and then not (Is_Tagged_Type (T)
and then Is_Derived_Type (T))))
then
if ((Bytes_Big_Endian and then SSO_Set_Low_By_Default (T))
or else
((not Bytes_Big_Endian) and then SSO_Set_High_By_Default (T)))
Reversed :=
(Bytes_Big_Endian and then SSO_Set_Low_By_Default (T))
or else
(not Bytes_Big_Endian and then SSO_Set_High_By_Default (T));
if (SSO_Set_Low_By_Default (T) or else SSO_Set_High_By_Default (T))
-- For a record type, if native bit order is specified explicitly,
-- then never set reverse SSO from default.
-- For a record type, if bit order is specified explicitly, then
-- do not set SSO from default if not consistent.
and then not
(Is_Record_Type (T)
and then Has_Rep_Item (T, Name_Bit_Order)
and then not Reverse_Bit_Order (T))
and then Reverse_Bit_Order (T) /= Reversed)
then
-- If flags cause reverse storage order, then set the result. Note
-- that we would have ignored the pragma setting the non default
-- storage order in any case, hence the assertion at this point.
pragma Assert (Support_Nondefault_SSO_On_Target);
Set_Reverse_Storage_Order (T);
pragma Assert
(not Reversed or else Support_Nondefault_SSO_On_Target);
Set_Reverse_Storage_Order (T, Reversed);
-- For a record type, also set reversed bit order. Note that if
-- a bit order has been specified explicitly, then this is a
-- no-op, as per the guard above.
-- For a record type, also set reversed bit order. Note: if a bit
-- order has been specified explicitly, then this is a no-op.
if Is_Record_Type (T) then
Set_Reverse_Bit_Order (T);
Set_Reverse_Bit_Order (T, Reversed);
end if;
end if;
end if;
......
gcc/ada/s-valllu.adb
......@@ -65,6 +65,13 @@ package body System.Val_LLU is
-- Digit value
begin
-- We do not tolerate strings with Str'Last = Positive'Last
if Str'Last = Positive'Last then
raise Program_Error with
"string upper bound is Positive'Last, not supported";
end if;
P := Ptr.all;
Uval := Character'Pos (Str (P)) - Character'Pos ('0');
P := P + 1;
......
gcc/ada/s-valllu.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
......@@ -66,6 +66,10 @@ package System.Val_LLU is
-- Note: if Str is empty, i.e. if Max is less than Ptr, then this is a
-- special case of an all-blank string, and Ptr is unchanged, and hence
-- is greater than Max as required in this case.
--
-- Note: this routine should not be called with Str'Last = Positive'Last.
-- If this occurs Program_Error is raised with a message noting that this
-- case is not supported. Most such cases are eliminated by the caller.
function Scan_Long_Long_Unsigned
(Str : String;
......@@ -73,6 +77,7 @@ package System.Val_LLU is
Max : Integer) return System.Unsigned_Types.Long_Long_Unsigned;
-- Same as Scan_Raw_Long_Long_Unsigned, except scans optional leading
-- blanks, and an optional leading plus sign.
--
-- Note: if a minus sign is present, Constraint_Error will be raised.
-- Note: trailing blanks are not scanned.
......
gcc/ada/s-valrea.adb
......@@ -152,6 +152,13 @@ package body System.Val_Real is
-- Start of processing for System.Scan_Real
begin
-- We do not tolerate strings with Str'Last = Positive'Last
if Str'Last = Positive'Last then
raise Program_Error with
"string upper bound is Positive'Last, not supported";
end if;
-- We call the floating-point processor reset routine so that we can
-- be sure the floating-point processor is properly set for conversion
-- calls. This is notably need on Windows, where calls to the operating
......
gcc/ada/s-valrea.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
......@@ -60,6 +60,10 @@ package System.Val_Real is
-- Note: if Str is null, i.e. if Max is less than Ptr, then this is a
-- special case of an all-blank string, and Ptr is unchanged, and hence
-- is greater than Max as required in this case.
--
-- Note: this routine should not be called with Str'Last = Positive'Last.
-- If this occurs Program_Error is raised with a message noting that this
-- case is not supported. Most such cases are eliminated by the caller.
function Value_Real (Str : String) return Long_Long_Float;
-- Used in computing X'Value (Str) where X is a floating-point type or an
......
gcc/ada/s-valuns.adb
......@@ -65,6 +65,13 @@ package body System.Val_Uns is
-- Digit value
begin
-- We do not tolerate strings with Str'Last = Positive'Last
if Str'Last = Positive'Last then
raise Program_Error with
"string upper bound is Positive'Last, not supported";
end if;
P := Ptr.all;
Uval := Character'Pos (Str (P)) - Character'Pos ('0');
P := P + 1;
......
gcc/ada/s-valuns.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
......@@ -66,6 +66,10 @@ package System.Val_Uns is
-- Note: if Str is empty, i.e. if Max is less than Ptr, then this is a
-- special case of an all-blank string, and Ptr is unchanged, and hence
-- is greater than Max as required in this case.
--
-- Note: this routine should not be called with Str'Last = Positive'Last.
-- If this occurs Program_Error is raised with a message noting that this
-- case is not supported. Most such cases are eliminated by the caller.
function Scan_Unsigned
(Str : String;
......@@ -73,6 +77,7 @@ package System.Val_Uns is
Max : Integer) return System.Unsigned_Types.Unsigned;
-- Same as Scan_Raw_Unsigned, except scans optional leading
-- blanks, and an optional leading plus sign.
--
-- Note: if a minus sign is present, Constraint_Error will be raised.
-- Note: trailing blanks are not scanned.
......
gcc/ada/s-valuti.ads
......@@ -71,6 +71,9 @@ package System.Val_Util is
-- special case of an all-blank string, and Ptr is unchanged, and hence
-- is greater than Max as required in this case. Constraint_Error is also
-- raised in this case.
--
-- This routine must not be called with Str'Last = Positive'Last. There is
-- no check for this case, the caller must ensure this condition is met.
procedure Scan_Plus_Sign
(Str : String;
......@@ -95,6 +98,9 @@ package System.Val_Util is
-- returning a suitable large value. If the base is zero, then any value
-- is allowed, and otherwise the large value will either cause underflow
-- or overflow during the scaling process which is fine.
--
-- This routine must not be called with Str'Last = Positive'Last. There is
-- no check for this case, the caller must ensure this condition is met.
procedure Scan_Trailing_Blanks (Str : String; P : Positive);
-- Checks that the remainder of the field Str (P .. Str'Last) is all
......@@ -113,5 +119,8 @@ package System.Val_Util is
-- where the underscore is invalid, Constraint_Error is raised with Ptr
-- set appropriately, otherwise control returns with P incremented past
-- the underscore.
--
-- This routine must not be called with Str'Last = Positive'Last. There is
-- no check for this case, the caller must ensure this condition is met.
end System.Val_Util;
gcc/ada/sem_ch12.adb
......@@ -1207,7 +1207,8 @@ package body Sem_Ch12 is
if No (Found_Assoc) then
Default :=
Make_Generic_Association (Loc,
Selector_Name => New_Occurrence_Of (Id, Loc),
Selector_Name =>
New_Occurrence_Of (Id, Loc),
Explicit_Generic_Actual_Parameter => Empty);
Set_Box_Present (Default);
Append (Default, Default_Formals);
......@@ -1421,10 +1422,10 @@ package body Sem_Ch12 is
Error_Msg_Sloc := Sloc (Gen_Unit);
Error_Msg_NE
("missing actual&",
Instantiation_Node,
Defining_Identifier (Formal));
Error_Msg_NE ("\in instantiation of & declared#",
Instantiation_Node, Gen_Unit);
Instantiation_Node, Defining_Identifier (Formal));
Error_Msg_NE
("\in instantiation of & declared#",
Instantiation_Node, Gen_Unit);
Abandon_Instantiation (Instantiation_Node);
end if;
......@@ -1575,9 +1576,9 @@ package body Sem_Ch12 is
when N_Formal_Package_Declaration =>
Match :=
Matching_Actual (
Defining_Identifier (Formal),
Defining_Identifier (Original_Node (Analyzed_Formal)));
Matching_Actual
(Defining_Identifier (Formal),
Defining_Identifier (Original_Node (Analyzed_Formal)));
if No (Match) then
if Partial_Parameterization then
......@@ -1587,9 +1588,10 @@ package body Sem_Ch12 is
Error_Msg_Sloc := Sloc (Gen_Unit);
Error_Msg_NE
("missing actual&",
Instantiation_Node, Defining_Identifier (Formal));
Error_Msg_NE ("\in instantiation of & declared#",
Instantiation_Node, Gen_Unit);
Instantiation_Node, Defining_Identifier (Formal));
Error_Msg_NE
("\in instantiation of & declared#",
Instantiation_Node, Gen_Unit);
Abandon_Instantiation (Instantiation_Node);
end if;
......@@ -1632,14 +1634,13 @@ package body Sem_Ch12 is
if Present (Selector_Name (Actual)) then
Error_Msg_NE
("unmatched actual&",
Actual, Selector_Name (Actual));
Error_Msg_NE ("\in instantiation of& declared#",
Actual, Gen_Unit);
("unmatched actual &", Actual, Selector_Name (Actual));
Error_Msg_NE
("\in instantiation of & declared#", Actual, Gen_Unit);
else
Error_Msg_NE
("unmatched actual in instantiation of& declared#",
Actual, Gen_Unit);
("unmatched actual in instantiation of & declared#",
Actual, Gen_Unit);
end if;
end if;
......@@ -1681,9 +1682,10 @@ package body Sem_Ch12 is
Subp := Node (Elmt);
New_D :=
Make_Generic_Association (Sloc (Subp),
Selector_Name => New_Occurrence_Of (Subp, Sloc (Subp)),
Explicit_Generic_Actual_Parameter =>
New_Occurrence_Of (Subp, Sloc (Subp)));
Selector_Name =>
New_Occurrence_Of (Subp, Sloc (Subp)),
Explicit_Generic_Actual_Parameter =>
New_Occurrence_Of (Subp, Sloc (Subp)));
Mark_Rewrite_Insertion (New_D);
Append_To (Actuals, New_D);
Next_Elmt (Elmt);
......@@ -1750,8 +1752,8 @@ package body Sem_Ch12 is
then
Error_Msg_N
("in a formal, a subtype indication can only be "
& "a subtype mark (RM 12.5.3(3))",
Subtype_Indication (Component_Definition (Def)));
& "a subtype mark (RM 12.5.3(3))",
Subtype_Indication (Component_Definition (Def)));
end if;
end Analyze_Formal_Array_Type;
......@@ -1888,10 +1890,10 @@ package body Sem_Ch12 is
else
New_N :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => T,
Defining_Identifier => T,
Discriminant_Specifications =>
Discriminant_Specifications (Parent (T)),
Type_Definition =>
Type_Definition =>
Make_Derived_Type_Definition (Loc,
Subtype_Indication => Subtype_Mark (Def)));
......@@ -2031,7 +2033,7 @@ package body Sem_Ch12 is
New_N :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => T,
Type_Definition => Def);
Type_Definition => Def);
Rewrite (N, New_N);
Analyze (N);
......@@ -2092,8 +2094,7 @@ package body Sem_Ch12 is
elsif Can_Never_Be_Null (T) then
Error_Msg_NE
("`NOT NULL` not allowed (& already excludes null)",
N, T);
("`NOT NULL` not allowed (& already excludes null)", N, T);
end if;
end if;
......@@ -2394,10 +2395,10 @@ package body Sem_Ch12 is
Restore_Env;
goto Leave;
elsif Gen_Unit = Current_Scope then
elsif Gen_Unit = Current_Scope then
Error_Msg_N
("generic package cannot be used as a formal package of itself",
Gen_Id);
Gen_Id);
Restore_Env;
goto Leave;
......@@ -2410,14 +2411,12 @@ package body Sem_Ch12 is
Error_Msg_N
("generic parent cannot be used as formal package "
& "of a child unit",
Gen_Id);
& "of a child unit", Gen_Id);
else
Error_Msg_N
("generic package cannot be used as a formal package "
& "within itself",
Gen_Id);
& "within itself", Gen_Id);
Restore_Env;
goto Leave;
end if;
......@@ -2439,7 +2438,7 @@ package body Sem_Ch12 is
if Chars (Gen_Name) = Chars (Pack_Id) then
Error_Msg_NE
("& is hidden within declaration of formal package",
Gen_Id, Gen_Name);
Gen_Id, Gen_Name);
end if;
end;
......@@ -2503,9 +2502,8 @@ package body Sem_Ch12 is
Set_Inner_Instances (Formal, New_Elmt_List);
Push_Scope (Formal);
if Is_Child_Unit (Gen_Unit)
and then Parent_Installed
then
if Is_Child_Unit (Gen_Unit) and then Parent_Installed then
-- Similarly, we have to make the name of the formal visible in the
-- parent instance, to resolve properly fully qualified names that
-- may appear in the generic unit. The parent instance has been
......@@ -2538,15 +2536,11 @@ package body Sem_Ch12 is
begin
E := First_Entity (Formal);
while Present (E) loop
if Associations
and then not Is_Generic_Formal (E)
then
if Associations and then not Is_Generic_Formal (E) then
Set_Is_Hidden (E);
end if;
if Ekind (E) = E_Package
and then Renamed_Entity (E) = Formal
then
if Ekind (E) = E_Package and then Renamed_Entity (E) = Formal then
Set_Is_Hidden (E);
exit;
end if;
......@@ -2697,8 +2691,8 @@ package body Sem_Ch12 is
and then Is_Incomplete_Type (Ctrl_Type)
then
Error_Msg_NE
("controlling type of abstract formal subprogram cannot " &
"be incomplete type", N, Ctrl_Type);
("controlling type of abstract formal subprogram cannot "
& "be incomplete type", N, Ctrl_Type);
else
Check_Controlling_Formals (Ctrl_Type, Nam);
......@@ -2974,7 +2968,6 @@ package body Sem_Ch12 is
-- caller.
Gen_Parm_Decl := First (Generic_Formal_Declarations (N));
while Present (Gen_Parm_Decl) loop
Analyze (Gen_Parm_Decl);
Next (Gen_Parm_Decl);
......@@ -3011,13 +3004,12 @@ package body Sem_Ch12 is
Defining_Unit_Name =>
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Defining_Entity (N)), "GH")),
Name => Make_Identifier (Loc, Chars (Defining_Entity (N))));
Name =>
Make_Identifier (Loc, Chars (Defining_Entity (N))));
if Present (Decls) then
Decl := First (Decls);
while Present (Decl)
and then Nkind (Decl) = N_Pragma
loop
while Present (Decl) and then Nkind (Decl) = N_Pragma loop
Next (Decl);
end loop;
......@@ -3229,8 +3221,9 @@ package body Sem_Ch12 is
if Is_Abstract_Type (Designated_Type (Result_Type))
and then Ada_Version >= Ada_2012
then
Error_Msg_N ("generic function cannot have an access result"
& " that designates an abstract type", Spec);
Error_Msg_N
("generic function cannot have an access result "
& "that designates an abstract type", Spec);
end if;
else
......@@ -3423,7 +3416,8 @@ package body Sem_Ch12 is
if Nkind (Defining_Unit_Name (N)) = N_Defining_Program_Unit_Name then
Act_Decl_Name :=
Make_Defining_Program_Unit_Name (Loc,
Name => New_Copy_Tree (Name (Defining_Unit_Name (N))),
Name =>
New_Copy_Tree (Name (Defining_Unit_Name (N))),
Defining_Identifier => Act_Decl_Id);
else
Act_Decl_Name := Act_Decl_Id;
......@@ -3643,8 +3637,7 @@ package body Sem_Ch12 is
begin
ASN1 := First (Aspect_Specifications (N));
while Present (ASN1) loop
if Chars (Identifier (ASN1))
= Name_Default_Storage_Pool
if Chars (Identifier (ASN1)) = Name_Default_Storage_Pool
then
-- If generic carries a default storage pool, remove
-- it in favor of the instance one.
......@@ -3694,7 +3687,6 @@ package body Sem_Ch12 is
and then not Is_Child_Unit (Gen_Unit)
then
Scop := Scope (Gen_Unit);
while Present (Scop)
and then Scop /= Standard_Standard
loop
......@@ -4274,10 +4266,7 @@ package body Sem_Ch12 is
-- must be made invisible as well.
S := Current_Scope;
while Present (S)
and then S /= Standard_Standard
loop
while Present (S) and then S /= Standard_Standard loop
if Is_Generic_Instance (S)
and then (In_Package_Body (S)
or else Ekind_In (S, E_Procedure, E_Function))
......@@ -4302,9 +4291,8 @@ package body Sem_Ch12 is
or else (Ekind (Curr_Unit) = E_Package_Body
and then S = Spec_Entity (Curr_Unit))
or else (Ekind (Curr_Unit) = E_Subprogram_Body
and then S =
Corresponding_Spec
(Unit_Declaration_Node (Curr_Unit)))
and then S = Corresponding_Spec
(Unit_Declaration_Node (Curr_Unit)))
then
Removed := True;
......@@ -4409,9 +4397,7 @@ package body Sem_Ch12 is
Par : Entity_Id;
begin
Par := Scope (Curr_Scope);
while (Present (Par))
and then Par /= Standard_Standard
loop
while (Present (Par)) and then Par /= Standard_Standard loop
Install_Private_Declarations (Par);
Par := Scope (Par);
end loop;
......@@ -4424,9 +4410,7 @@ package body Sem_Ch12 is
-- scopes (and those local to the child unit itself) need to be
-- installed explicitly.
if Is_Child_Unit (Curr_Unit)
and then Removed
then
if Is_Child_Unit (Curr_Unit) and then Removed then
for J in reverse 1 .. Num_Inner + 1 loop
Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause :=
Use_Clauses (J);
......@@ -4968,11 +4952,11 @@ package body Sem_Ch12 is
and then Is_Controlling_Formal (Formal)
and then not Can_Never_Be_Null (Formal)
then
Error_Msg_NE ("access parameter& is controlling,",
N, Formal);
Error_Msg_NE
("\corresponding parameter of & must be"
& " explicitly null-excluding", N, Gen_Id);
("access parameter& is controlling,", N, Formal);
Error_Msg_NE
("\corresponding parameter of & must be "
& "explicitly null-excluding", N, Gen_Id);
end if;
Next_Formal (Formal);
......@@ -5129,6 +5113,7 @@ package body Sem_Ch12 is
Actual_Subp : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Formal_Subp);
Ret_Type : constant Entity_Id := Get_Instance_Of (Etype (Formal_Subp));
Actuals : List_Id;
Decl : Node_Id;
Func_Name : Node_Id;
......@@ -5150,12 +5135,7 @@ package body Sem_Ch12 is
Actuals := New_List;
Profile := New_List;
if Present (Actual_Subp) then
Act_F := First_Formal (Actual_Subp);
else
Act_F := Empty;
end if;
Act_F := First_Formal (Actual_Subp);
Form_F := First_Formal (Formal_Subp);
while Present (Form_F) loop
......@@ -5166,7 +5146,8 @@ package body Sem_Ch12 is
New_F := Make_Defining_Identifier (Loc, Chars (Form_F));
Parm_Type := New_Occurrence_Of (Etype (Act_F), Loc);
Parm_Type :=
New_Occurrence_Of (Get_Instance_Of (Etype (Form_F)), Loc);
Append_To (Profile,
Make_Parameter_Specification (Loc,
......@@ -5185,8 +5166,7 @@ package body Sem_Ch12 is
Make_Function_Specification (Loc,
Defining_Unit_Name => Func,
Parameter_Specifications => Profile,
Result_Definition =>
Make_Identifier (Loc, Chars (Etype (Formal_Subp))));
Result_Definition => New_Occurrence_Of (Ret_Type, Loc));
Decl :=
Make_Expression_Function (Loc,
......@@ -5526,7 +5506,8 @@ package body Sem_Ch12 is
-- original name.
elsif Is_Entity_Name (Original_Node (Constant_Value (Ent))) then
Ent := Entity (Original_Node (Constant_Value (Ent)));
Ent := Entity (Original_Node (Constant_Value (Ent)));
else
return False;
end if;
......@@ -5574,9 +5555,7 @@ package body Sem_Ch12 is
-- Start of processing for Check_Formal_Package_Instance
begin
while Present (E1)
and then Present (E2)
loop
while Present (E1) and then Present (E2) loop
exit when Ekind (E1) = E_Package
and then Renamed_Entity (E1) = Renamed_Entity (Actual_Pack);
......@@ -5597,9 +5576,7 @@ package body Sem_Ch12 is
and then not Comes_From_Source (E1)
and then Chars (E1) /= Chars (E2)
then
while Present (E1)
and then Chars (E1) /= Chars (E2)
loop
while Present (E1) and then Chars (E1) /= Chars (E2) loop
Next_Entity (E1);
end loop;
end if;
......@@ -5631,9 +5608,7 @@ package body Sem_Ch12 is
-- If E2 is a formal type declaration, it is a defaulted parameter
-- and needs no checking.
if not Is_Itype (E1)
and then not Is_Itype (E2)
then
if not Is_Itype (E1) and then not Is_Itype (E2) then
Check_Mismatch
(not Is_Type (E2)
or else Etype (E1) /= Etype (E2)
......@@ -5694,15 +5669,15 @@ package body Sem_Ch12 is
(not Same_Instantiated_Constant
(Entity (Expr1), Entity (Expr2)));
end if;
else
Check_Mismatch (True);
end if;
elsif Is_Entity_Name (Original_Node (Expr1))
and then Is_Entity_Name (Expr2)
and then
Same_Instantiated_Constant
(Entity (Original_Node (Expr1)), Entity (Expr2))
and then Same_Instantiated_Constant
(Entity (Original_Node (Expr1)), Entity (Expr2))
then
null;
......@@ -6026,10 +6001,10 @@ package body Sem_Ch12 is
begin
if Is_Wrapper_Package (Instance) then
Gen_Id :=
Generic_Parent
(Specification
(Unit_Declaration_Node
(Related_Instance (Instance))));
Generic_Parent
(Specification
(Unit_Declaration_Node
(Related_Instance (Instance))));
else
Gen_Id :=
Generic_Parent (Package_Specification (Instance));
......@@ -6409,8 +6384,7 @@ package body Sem_Ch12 is
and then Is_Generic_Unit (Scope (Renamed_Object (E)))
and then Nkind (Name (Parent (E))) = N_Expanded_Name
then
Rewrite (Gen_Id,
New_Copy_Tree (Name (Parent (E))));
Rewrite (Gen_Id, New_Copy_Tree (Name (Parent (E))));
Inst_Par := Entity (Prefix (Gen_Id));
if not In_Open_Scopes (Inst_Par) then
......@@ -6458,7 +6432,7 @@ package body Sem_Ch12 is
Error_Msg_Node_2 := Scope (Act_Decl_Id);
Error_Msg_NE
("generic unit & is implicitly declared in &",
Defining_Unit_Name (N), Gen_Unit);
Defining_Unit_Name (N), Gen_Unit);
Error_Msg_N ("\instance must have different name",
Defining_Unit_Name (N));
end if;
......@@ -6616,9 +6590,8 @@ package body Sem_Ch12 is
if Nkind (Actual) = N_Subtype_Declaration then
Gen_T := Generic_Parent_Type (Actual);
if Present (Gen_T)
and then Is_Tagged_Type (Gen_T)
then
if Present (Gen_T) and then Is_Tagged_Type (Gen_T) then
-- Traverse the list of primitives of the actual types
-- searching for hidden primitives that are visible in the
-- corresponding generic formal; leave them visible and
......@@ -6677,7 +6650,7 @@ package body Sem_Ch12 is
Error_Msg_Node_2 := Inner;
Error_Msg_NE
("circular Instantiation: & instantiated within &!",
N, Scop);
N, Scop);
return True;
elsif Node (Elmt) = Inner then
......@@ -6687,7 +6660,7 @@ package body Sem_Ch12 is
Error_Msg_Node_2 := Inner;
Error_Msg_NE
("circular Instantiation: & instantiated within &!",
N, Node (Elmt));
N, Node (Elmt));
return True;
end if;
......@@ -7195,9 +7168,7 @@ package body Sem_Ch12 is
Rt : Entity_Id;
begin
if Present (T)
and then Is_Private_Type (T)
then
if Present (T) and then Is_Private_Type (T) then
Switch_View (T);
end if;
......@@ -7256,9 +7227,8 @@ package body Sem_Ch12 is
-- Retrieve the allocator node in the generic copy
Acc_T := Etype (Parent (Parent (T)));
if Present (Acc_T)
and then Is_Private_Type (Acc_T)
then
if Present (Acc_T) and then Is_Private_Type (Acc_T) then
Switch_View (Acc_T);
end if;
end if;
......@@ -7321,9 +7291,8 @@ package body Sem_Ch12 is
and then Instantiating
then
-- If the string is declared in an outer scope, the string_literal
-- subtype created for it may have the wrong scope. We force the
-- reanalysis of the constant to generate a new itype in the proper
-- context.
-- subtype created for it may have the wrong scope. Force reanalysis
-- of the constant to generate a new itype in the proper context.
Set_Etype (New_N, Empty);
Set_Analyzed (New_N, False);
......@@ -7857,7 +7826,8 @@ package body Sem_Ch12 is
and then Earlier (Inst_Node, Gen_Body)
then
if Nkind (Enc_G) = N_Package_Body then
E_G_Id := Corresponding_Spec (Enc_G);
E_G_Id :=
Corresponding_Spec (Enc_G);
else pragma Assert (Nkind (Enc_G) = N_Package_Body_Stub);
E_G_Id :=
Corresponding_Spec (Proper_Body (Unit (Library_Unit (Enc_G))));
......@@ -7925,6 +7895,7 @@ package body Sem_Ch12 is
begin
if Res /= Assoc_Null then
return Generic_Renamings.Table (Res).Act_Id;
else
-- On exit, entity is not instantiated: not a generic parameter, or
-- else parameter of an inner generic unit.
......@@ -8110,9 +8081,10 @@ package body Sem_Ch12 is
Inst : Node_Id) return Boolean
is
Decls : constant Node_Id := Parent (F_Node);
Nod : Node_Id := Parent (Inst);
Nod : Node_Id;
begin
Nod := Parent (Inst);
while Present (Nod) loop
if Nod = Decls then
return True;
......@@ -8326,9 +8298,7 @@ package body Sem_Ch12 is
begin
S := Scope (Gen);
while Present (S)
and then S /= Standard_Standard
loop
while Present (S) and then S /= Standard_Standard loop
if Is_Generic_Instance (S)
and then In_Same_Source_Unit (S, N)
then
......@@ -8386,9 +8356,7 @@ package body Sem_Ch12 is
-- In these three cases the freeze node of the previous
-- instance is not relevant.
while Present (Scop)
and then Scop /= Standard_Standard
loop
while Present (Scop) and then Scop /= Standard_Standard loop
exit when Scop = Par_I
or else
(Is_Generic_Instance (Scop)
......@@ -8405,8 +8373,8 @@ package body Sem_Ch12 is
-- the current scope as well.
elsif Present (Next (N))
and then Nkind_In (Next (N),
N_Subprogram_Body, N_Package_Body)
and then Nkind_In (Next (N), N_Subprogram_Body,
N_Package_Body)
and then Comes_From_Source (Next (N))
then
null;
......@@ -8419,7 +8387,7 @@ package body Sem_Ch12 is
-- Current instance is within an unrelated body
elsif Present (Enclosing_N)
and then Enclosing_N /= Enclosing_Body (Par_I)
and then Enclosing_N /= Enclosing_Body (Par_I)
then
null;
......@@ -8597,11 +8565,11 @@ package body Sem_Ch12 is
(Gen_Unit = Act_Unit
and then (Nkind_In (Gen_Unit, N_Package_Declaration,
N_Generic_Package_Declaration)
or else (Gen_Unit = Body_Unit
and then True_Sloc (N) < Sloc (Orig_Body)))
or else (Gen_Unit = Body_Unit
and then True_Sloc (N) < Sloc (Orig_Body)))
and then Is_In_Main_Unit (Gen_Unit)
and then (Scope (Act_Id) = Scope (Gen_Id)
or else In_Same_Enclosing_Subp));
or else In_Same_Enclosing_Subp));
-- If this is an early instantiation, the freeze node is placed after
-- the generic body. Otherwise, if the generic appears in an instance,
......@@ -8784,6 +8752,7 @@ package body Sem_Ch12 is
end if;
Next_Entity (E);
if Present (Gen_E) then
Next_Entity (Gen_E);
end if;
......@@ -8904,9 +8873,8 @@ package body Sem_Ch12 is
First_Gen := Gen_Par;
while Present (Gen_Par)
and then Is_Child_Unit (Gen_Par)
loop
while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop
-- Load grandparent instance as well
Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
......@@ -9411,8 +9379,8 @@ package body Sem_Ch12 is
Defining_Unit_Name => New_Copy (Defining_Identifier (Formal)),
Name => New_Occurrence_Of (Actual_Pack, Loc));
Set_Associated_Formal_Package (Defining_Unit_Name (Nod),
Defining_Identifier (Formal));
Set_Associated_Formal_Package
(Defining_Unit_Name (Nod), Defining_Identifier (Formal));
Decls := New_List (Nod);
-- If the formal F has a box, then the generic declarations are
......@@ -9551,8 +9519,8 @@ package body Sem_Ch12 is
Append_To (Decls,
Make_Package_Instantiation (Sloc (Actual),
Defining_Unit_Name => I_Pack,
Name =>
Defining_Unit_Name => I_Pack,
Name =>
New_Occurrence_Of
(Get_Instance_Of (Gen_Parent), Sloc (Actual)),
Generic_Associations =>
......@@ -9640,7 +9608,7 @@ package body Sem_Ch12 is
end if;
Error_Msg_NE
("expect subprogram or entry name in instantiation of&",
("expect subprogram or entry name in instantiation of &",
Instantiation_Node, Formal_Sub);
Abandon_Instantiation (Instantiation_Node);
end Valid_Actual_Subprogram;
......@@ -9924,11 +9892,11 @@ package body Sem_Ch12 is
if No (Actual) then
Error_Msg_NE
("missing actual&",
("missing actual &",
Instantiation_Node, Gen_Obj);
Error_Msg_NE
("\in instantiation of & declared#",
Instantiation_Node, Scope (A_Gen_Obj));
Instantiation_Node, Scope (A_Gen_Obj));
Abandon_Instantiation (Instantiation_Node);
end if;
......@@ -10023,8 +9991,7 @@ package body Sem_Ch12 is
Resolve (Actual, Ftyp);
if not Denotes_Variable (Actual) then
Error_Msg_NE
("actual for& must be a variable", Actual, Gen_Obj);
Error_Msg_NE ("actual for& must be a variable", Actual, Gen_Obj);
elsif Base_Type (Ftyp) /= Base_Type (Etype (Actual)) then
......@@ -10220,9 +10187,8 @@ package body Sem_Ch12 is
if Ada_Version >= Ada_2005
and then Present (Actual_Decl)
and then
Nkind_In (Actual_Decl, N_Formal_Object_Declaration,
N_Object_Declaration)
and then Nkind_In (Actual_Decl, N_Formal_Object_Declaration,
N_Object_Declaration)
and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration
and then not Has_Null_Exclusion (Actual_Decl)
and then Has_Null_Exclusion (Analyzed_Formal)
......@@ -10509,8 +10475,7 @@ package body Sem_Ch12 is
if Nkind (Defining_Unit_Name (Act_Spec)) =
N_Defining_Program_Unit_Name
then
Set_Scope
(Defining_Entity (Inst_Node), Scope (Act_Decl_Id));
Set_Scope (Defining_Entity (Inst_Node), Scope (Act_Decl_Id));
end if;
end if;
......@@ -10791,7 +10756,7 @@ package body Sem_Ch12 is
-- If there is a formal subprogram with the same name as the unit
-- itself, do not add this renaming declaration. This is a temporary
-- fix for one ACVC test. ???
-- fix for one ACATS test. ???
Prev_Formal := First_Entity (Pack_Id);
while Present (Prev_Formal) loop
......@@ -10993,7 +10958,7 @@ package body Sem_Ch12 is
then
Error_Msg_NE
("actual for& cannot be a type with predicate",
Instantiation_Node, A_Gen_T);
Instantiation_Node, A_Gen_T);
elsif No_Dynamic_Predicate_On_Actual (A_Gen_T)
and then Has_Predicates (Act_T)
......@@ -11001,7 +10966,7 @@ package body Sem_Ch12 is
then
Error_Msg_NE
("actual for& cannot be a type with a dynamic predicate",
Instantiation_Node, A_Gen_T);
Instantiation_Node, A_Gen_T);
end if;
end Diagnose_Predicated_Actual;
......@@ -11473,9 +11438,9 @@ package body Sem_Ch12 is
elsif Nkind (Parent (Act_T)) = N_Full_Type_Declaration
and then Nkind (Type_Definition (Parent (Act_T))) =
N_Derived_Type_Definition
and then not Synchronized_Present (Type_Definition
(Parent (Act_T)))
N_Derived_Type_Definition
and then not Synchronized_Present
(Type_Definition (Parent (Act_T)))
then
Error_Msg_N
("actual of synchronized type must be synchronized", Actual);
......@@ -11506,16 +11471,14 @@ package body Sem_Ch12 is
and then not Unknown_Discriminants_Present (Formal)
and then Is_Indefinite_Subtype (Act_T)
then
Error_Msg_N
("actual subtype must be constrained", Actual);
Error_Msg_N ("actual subtype must be constrained", Actual);
Abandon_Instantiation (Actual);
end if;
if not Unknown_Discriminants_Present (Formal) then
if Is_Constrained (Ancestor) then
if not Is_Constrained (Act_T) then
Error_Msg_N
("actual subtype must be constrained", Actual);
Error_Msg_N ("actual subtype must be constrained", Actual);
Abandon_Instantiation (Actual);
end if;
......@@ -11559,8 +11522,8 @@ package body Sem_Ch12 is
No (Corresponding_Discriminant (Actual_Discr))
then
Error_Msg_NE
("discriminant & does not correspond " &
"to ancestor discriminant", Actual, Actual_Discr);
("discriminant & does not correspond "
& "to ancestor discriminant", Actual, Actual_Discr);
Abandon_Instantiation (Actual);
end if;
......@@ -11711,13 +11674,13 @@ package body Sem_Ch12 is
Anc_F_Type := Etype (Anc_Formal);
Act_F_Type := Etype (Act_Formal);
if Ekind (Anc_F_Type)
= E_Anonymous_Access_Type
if Ekind (Anc_F_Type) =
E_Anonymous_Access_Type
then
Anc_F_Type := Designated_Type (Anc_F_Type);
if Ekind (Act_F_Type)
= E_Anonymous_Access_Type
if Ekind (Act_F_Type) =
E_Anonymous_Access_Type
then
Act_F_Type :=
Designated_Type (Act_F_Type);
......@@ -11769,14 +11732,14 @@ package body Sem_Ch12 is
Anc_F_Type := Etype (Anc_Subp);
Act_F_Type := Etype (Act_Subp);
if Ekind (Anc_F_Type)
= E_Anonymous_Access_Type
if Ekind (Anc_F_Type) =
E_Anonymous_Access_Type
then
Anc_F_Type :=
Designated_Type (Anc_F_Type);
if Ekind (Act_F_Type)
= E_Anonymous_Access_Type
if Ekind (Act_F_Type) =
E_Anonymous_Access_Type
then
Act_F_Type :=
Designated_Type (Act_F_Type);
......@@ -11804,9 +11767,8 @@ package body Sem_Ch12 is
and then Anc_F_Type /= Act_F_Type
and then
Has_Controlling_Result (Anc_Subp)
and then
not Is_Tagged_Ancestor
(Anc_F_Type, Act_F_Type)
and then not Is_Tagged_Ancestor
(Anc_F_Type, Act_F_Type)
then
Subprograms_Correspond := False;
end if;
......@@ -11818,10 +11780,9 @@ package body Sem_Ch12 is
if Subprograms_Correspond then
Error_Msg_NE
("abstract subprogram & overrides " &
"nonabstract subprogram of ancestor",
Actual,
Act_Subp);
("abstract subprogram & overrides "
& "nonabstract subprogram of ancestor",
Actual, Act_Subp);
end if;
end if;
end if;
......@@ -11853,8 +11814,8 @@ package body Sem_Ch12 is
null;
else
Error_Msg_NE
("actual for non-limited & cannot be a limited type", Actual,
Gen_T);
("actual for non-limited & cannot be a limited type",
Actual, Gen_T);
Explain_Limited_Type (Act_T, Actual);
Abandon_Instantiation (Actual);
end if;
......@@ -11964,7 +11925,7 @@ package body Sem_Ch12 is
if not Is_Interface (Act_T) then
Error_Msg_NE
("actual for formal interface type must be an interface",
Actual, Gen_T);
Actual, Gen_T);
elsif Is_Limited_Type (Act_T) /= Is_Limited_Type (A_Gen_T)
or else Is_Task_Interface (A_Gen_T) /= Is_Task_Interface (Act_T)
......@@ -12162,7 +12123,7 @@ package body Sem_Ch12 is
if not Is_Discrete_Type (Act_T) then
Error_Msg_NE
("expect discrete type in instantiation of&",
Actual, Gen_T);
Actual, Gen_T);
Abandon_Instantiation (Actual);
end if;
......@@ -12275,9 +12236,8 @@ package body Sem_Ch12 is
Set_Generic_Parent_Type (Decl_Node, Ancestor);
end if;
elsif Nkind_In (Def,
N_Formal_Private_Type_Definition,
N_Formal_Incomplete_Type_Definition)
elsif Nkind_In (Def, N_Formal_Private_Type_Definition,
N_Formal_Incomplete_Type_Definition)
then
Set_Generic_Parent_Type (Decl_Node, A_Gen_T);
end if;
......@@ -12474,8 +12434,8 @@ package body Sem_Ch12 is
and then Nkind (True_Parent) /= N_Compilation_Unit
loop
if Nkind (True_Parent) = N_Package_Declaration
and then
Nkind (Original_Node (True_Parent)) = N_Package_Instantiation
and then
Nkind (Original_Node (True_Parent)) = N_Package_Instantiation
then
-- Parent is a compilation unit that is an instantiation.
-- Instantiation node has been replaced with package decl.
......@@ -12993,8 +12953,9 @@ package body Sem_Ch12 is
-- provide additional warning which might explain the error.
Set_Is_Immediately_Visible (Cur, Vis);
Error_Msg_NE ("& hides outer unit with the same name??",
N, Defining_Unit_Name (N));
Error_Msg_NE
("& hides outer unit with the same name??",
N, Defining_Unit_Name (N));
end if;
Abandon_Instantiation (Act);
......@@ -14102,8 +14063,8 @@ package body Sem_Ch12 is
Make_Explicit_Dereference (Loc,
Prefix => Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (Entity (Name (Prefix (N2))),
Loc))));
New_Occurrence_Of
(Entity (Name (Prefix (N2))), Loc))));
else
Set_Associated_Node (N, Empty);
......@@ -14144,6 +14105,7 @@ package body Sem_Ch12 is
if No (N2) then
Typ := Empty;
else
Typ := Etype (N2);
......@@ -14183,11 +14145,12 @@ package body Sem_Ch12 is
and then Comes_From_Source (Typ)
then
if Is_Immediately_Visible (Scope (Typ)) then
Nam := Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Chars (Scope (Typ))),
Selector_Name =>
Make_Identifier (Loc, Chars (Typ)));
Nam :=
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Chars (Scope (Typ))),
Selector_Name =>
Make_Identifier (Loc, Chars (Typ)));
else
Nam := Make_Identifier (Loc, Chars (Typ));
end if;
......@@ -14195,7 +14158,7 @@ package body Sem_Ch12 is
Qual :=
Make_Qualified_Expression (Loc,
Subtype_Mark => Nam,
Expression => Relocate_Node (N));
Expression => Relocate_Node (N));
end if;
end if;
......@@ -14472,8 +14435,8 @@ package body Sem_Ch12 is
end case;
if not OK then
Error_Msg_N ("attribute reference has wrong profile for subprogram",
Def);
Error_Msg_N
("attribute reference has wrong profile for subprogram", Def);
end if;
end Valid_Default_Attribute;
......
gcc/ada/sem_ch8.adb
......@@ -3457,19 +3457,18 @@ package body Sem_Ch8 is
-- points of call within an instance. Wrappers are generated if formal
-- subprogram is subject to axiomatization.
-- The types in the wrapper profiles are obtained from (instances of)
-- the types of the formal subprogram.
if Is_Actual
and then GNATprove_Mode
and then Present (Containing_Package_With_Ext_Axioms (Formal_Spec))
and then not Inside_A_Generic
then
if Ekind (Old_S) = E_Function then
Rewrite (N, Build_Function_Wrapper (New_S, Old_S));
Rewrite (N, Build_Function_Wrapper (Formal_Spec, Old_S));
Analyze (N);
-- For wrappers of operators, the types are obtained from (the
-- instances of) the types of the formal subprogram, not from the
-- actual subprogram, that carries predefined types.
elsif Ekind (Old_S) = E_Operator then
Rewrite (N, Build_Operator_Wrapper (Formal_Spec, Old_S));
Analyze (N);
......
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