OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

inline.adb (Back_End_Cannot_Inline): Use new flag Has_Pragma_Inline_Always instead of obsolete function Is_Always_Inlined 

2007-12-06  Robert Dewar  <dewar@adacore.com>

	* inline.adb (Back_End_Cannot_Inline): Use new flag
	Has_Pragma_Inline_Always instead of obsolete function Is_Always_Inlined

	* sem_ch6.ads, sem_ch6.adb (Analyze_Subprogram_Body): Use new flag
	Has_Pragma_Inline_Always instead.
	of obsolete function Is_Always_Inlined
	(Build_Body_To_Inline): Same change
	(Cannot_Inline): Same change
	Do not give warning on exception raise in No_Return function

	* sem_ch13.adb (Analyze_Record_Representation_Clause): If an inherited
	component has two inconsistent component clauses in the same record
	representation clause, favor the message that complains about
	duplication rather than inconsistency.
	Update comments.
	(Record_Representation_Clause): Do not warn on missing component
	clauses for inherited components of a type extension.
	(Rep_Item_Too_Late): Do not attempt to link pragma into rep chain for
	an overloadable item if it is a pragma that can apply to multiple
	overloadable entities (e.g. Inline) because a pragma cannot be on
	more than one chain at a time.
	(Validate_Unchecked_Conversion): Add code to warn on unchecked
	conversion where one of the operands is Ada.Calendar.Time.
	(Analyze_Attribute_Definition_Clause): Fix typo in error message.
	For now, ignore Component_Size clause on VM targets, as done for
	pragma Pack.

From-SVN: r130845
This commit is contained in:
Robert Dewar 2007-12-13 11:28:24 +01:00 committed by Arnaud Charlet
parent fcedf218ea
commit 800621e062
4 changed files with 238 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
gcc/ada/inline.adb
View File

@ -393,7 +393,7 @@ package body Inline is
-- If subprogram is marked Inline_Always, inlining is mandatory
if Is_Always_Inlined (Subp) then
if Has_Pragma_Inline_Always (Subp) then
return False;
end if;
@ -726,7 +726,7 @@ package body Inline is
E := First_Entity (P);
while Present (E) loop
if Is_Always_Inlined (E)
if Has_Pragma_Inline_Always (E)
or else (Front_End_Inlining and then Has_Pragma_Inline (E))
then
if not Is_Loaded (Bname) then

183
gcc/ada/sem_ch13.adb
View File

@ -1039,7 +1039,7 @@ package body Sem_Ch13 is
if Has_Component_Size_Clause (Btype) then
Error_Msg_N
("component size clase for& previously given", Nam);
("component size clause for& previously given", Nam);
elsif Csize /= No_Uint then
Check_Size (Expr, Component_Type (Btype), Csize, Biased);
@ -1058,34 +1058,50 @@ package body Sem_Ch13 is
-- that will be used to represent the biased subtype that
-- reflects the biased representation of components. We need
-- this subtype to get proper conversions on referencing
-- elements of the array.
-- elements of the array. Note that component size clauses
-- are ignored in VM mode.
if Biased then
New_Ctyp :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (U_Ent), 'C', 0, 'T'));
if VM_Target = No_VM then
if Biased then
New_Ctyp :=
Make_Defining_Identifier (Loc,
Chars =>
New_External_Name (Chars (U_Ent), 'C', 0, 'T'));
Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => New_Ctyp,
Subtype_Indication =>
New_Occurrence_Of (Component_Type (Btype), Loc));
Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => New_Ctyp,
Subtype_Indication =>
New_Occurrence_Of (Component_Type (Btype), Loc));
Set_Parent (Decl, N);
Analyze (Decl, Suppress => All_Checks);
Set_Parent (Decl, N);
Analyze (Decl, Suppress => All_Checks);
Set_Has_Delayed_Freeze (New_Ctyp, False);
Set_Esize (New_Ctyp, Csize);
Set_RM_Size (New_Ctyp, Csize);
Init_Alignment (New_Ctyp);
Set_Has_Biased_Representation (New_Ctyp, True);
Set_Is_Itype (New_Ctyp, True);
Set_Associated_Node_For_Itype (New_Ctyp, U_Ent);
Set_Has_Delayed_Freeze (New_Ctyp, False);
Set_Esize (New_Ctyp, Csize);
Set_RM_Size (New_Ctyp, Csize);
Init_Alignment (New_Ctyp);
Set_Has_Biased_Representation (New_Ctyp, True);
Set_Is_Itype (New_Ctyp, True);
Set_Associated_Node_For_Itype (New_Ctyp, U_Ent);
Set_Component_Type (Btype, New_Ctyp);
Set_Component_Type (Btype, New_Ctyp);
end if;
Set_Component_Size (Btype, Csize);
-- For VM case, we ignore component size clauses
else
-- Give a warning unless we are in GNAT mode, in which case
-- the warning is suppressed since it is not useful.
if not GNAT_Mode then
Error_Msg_N
("?component size ignored in this configuration", N);
end if;
end if;
Set_Component_Size (Btype, Csize);
Set_Has_Component_Size_Clause (Btype, True);
Set_Has_Non_Standard_Rep (Btype, True);
end if;
@ -2190,14 +2206,19 @@ package body Sem_Ch13 is
end;
end if;
-- Clear any existing component clauses for the type (this happens with
-- derived types, where we are now overriding the original).
-- For untagged types, clear any existing component clauses for the
-- type. If the type is derived, this is what allows us to override
-- a rep clause for the parent. For type extensions, the representation
-- of the inherited components is inherited, so we want to keep previous
-- component clauses for completeness.
Comp := First_Component_Or_Discriminant (Rectype);
while Present (Comp) loop
Set_Component_Clause (Comp, Empty);
Next_Component_Or_Discriminant (Comp);
end loop;
if not Is_Tagged_Type (Rectype) then
Comp := First_Component_Or_Discriminant (Rectype);
while Present (Comp) loop
Set_Component_Clause (Comp, Empty);
Next_Component_Or_Discriminant (Comp);
end loop;
end if;
-- All done if no component clauses
@ -2323,9 +2344,40 @@ package body Sem_Ch13 is
("component clause is for non-existent field", CC);
elsif Present (Component_Clause (Comp)) then
Error_Msg_Sloc := Sloc (Component_Clause (Comp));
Error_Msg_N
("component clause previously given#", CC);
-- Diagose duplicate rep clause, or check consistency
-- if this is inherited component. In a double fault,
-- there may be a duplicate inconsistent clause for an
-- inherited component.
if
Scope (Original_Record_Component (Comp)) = Rectype
or else Parent (Component_Clause (Comp)) = N
then
Error_Msg_Sloc := Sloc (Component_Clause (Comp));
Error_Msg_N ("component clause previously given#", CC);
else
declare
Rep1 : constant Node_Id := Component_Clause (Comp);
begin
if Intval (Position (Rep1)) /=
Intval (Position (CC))
or else Intval (First_Bit (Rep1)) /=
Intval (First_Bit (CC))
or else Intval (Last_Bit (Rep1)) /=
Intval (Last_Bit (CC))
then
Error_Msg_N ("component clause inconsistent "
& "with representation of ancestor", CC);
elsif Warn_On_Redundant_Constructs then
Error_Msg_N ("?redundant component clause "
& "for inherited component!", CC);
end if;
end;
end if;
else
-- Make reference for field in record rep clause and set
@ -2684,6 +2736,7 @@ package body Sem_Ch13 is
while Present (Comp) loop
if Present (Component_Clause (Comp)) then
Num_Repped_Components := Num_Repped_Components + 1;
else
Num_Unrepped_Components := Num_Unrepped_Components + 1;
end if;
@ -2702,6 +2755,7 @@ package body Sem_Ch13 is
Comp := First_Component_Or_Discriminant (Rectype);
while Present (Comp) loop
if No (Component_Clause (Comp))
and then Comes_From_Source (Comp)
and then (Is_Scalar_Type (Underlying_Type (Etype (Comp)))
or else Size_Known_At_Compile_Time
(Underlying_Type (Etype (Comp))))
@ -3413,6 +3467,17 @@ package body Sem_Ch13 is
return 0;
end if;
-- Note: In the following two tests for LoSet and HiSet, it may
-- seem redundant to test for N_Real_Literal here since normally
-- one would assume that the test for the value being known at
-- compile time includes this case. However, there is a glitch.
-- If the real literal comes from folding a non-static expression,
-- then we don't consider any non- static expression to be known
-- at compile time if we are in configurable run time mode (needed
-- in some cases to give a clearer definition of what is and what
-- is not accepted). So the test is indeed needed. Without it, we
-- would set neither Lo_Set nor Hi_Set and get an infinite loop.
if not LoSet then
if Nkind (Type_Low_Bound (Ancest)) = N_Real_Literal
or else Compile_Time_Known_Value (Type_Low_Bound (Ancest))
@ -3752,9 +3817,29 @@ package body Sem_Ch13 is
end if;
end if;
-- No error, link item into head of chain of rep items for the entity
-- No error, link item into head of chain of rep items for the entity,
-- but avoid chaining if we have an overloadable entity, and the pragma
-- is one that can apply to multiple overloaded entities.
if Is_Overloadable (T)
and then Nkind (N) = N_Pragma
and then (Chars (N) = Name_Convention
or else
Chars (N) = Name_Import
or else
Chars (N) = Name_Export
or else
Chars (N) = Name_External
or else
Chars (N) = Name_Interface)
then
null;
else
Record_Rep_Item (T, N);
end if;
-- Rep item was OK, not too late
Record_Rep_Item (T, N);
return False;
end Rep_Item_Too_Late;
@ -4186,6 +4271,36 @@ package body Sem_Ch13 is
("?conversion between pointers with different conventions!", N);
end if;
-- Warn if one of the operands is Ada.Calendar.Time. Do not emit a
-- warning when compiling GNAT-related sources.
if Warn_On_Unchecked_Conversion
and then not In_Predefined_Unit (N)
and then RTU_Loaded (Ada_Calendar)
and then
(Chars (Source) = Name_Time
or else
Chars (Target) = Name_Time)
then
-- If Ada.Calendar is loaded and the name of one of the operands is
-- Time, there is a good chance that this is Ada.Calendar.Time.
declare
Calendar_Time : constant Entity_Id :=
Full_View (RTE (RO_CA_Time));
begin
pragma Assert (Present (Calendar_Time));
if Source = Calendar_Time
or else Target = Calendar_Time
then
Error_Msg_N
("?representation of 'Time values may change between " &
"'G'N'A'T versions", N);
end if;
end;
end if;
-- Make entry in unchecked conversion table for later processing
-- by Validate_Unchecked_Conversions, which will check sizes and
-- alignments (using values set by the back-end where possible).

142
gcc/ada/sem_ch6.adb
View File

@ -196,12 +196,6 @@ package body Sem_Ch6 is
-- Flag functions that can be called without parameters, i.e. those that
-- have no parameters, or those for which defaults exist for all parameters
procedure Reference_Body_Formals (Spec : Entity_Id; Bod : Entity_Id);
-- If there is a separate spec for a subprogram or generic subprogram, the
-- formals of the body are treated as references to the corresponding
-- formals of the spec. This reference does not count as an actual use of
-- the formal, in order to diagnose formals that are unused in the body.
procedure Set_Formal_Validity (Formal_Id : Entity_Id);
-- Formal_Id is an formal parameter entity. This procedure deals with
-- setting the proper validity status for this entity, which depends
@ -213,9 +207,8 @@ package body Sem_Ch6 is
procedure Analyze_Return_Statement (N : Node_Id) is
pragma Assert (Nkind (N) = N_Simple_Return_Statement
or else
Nkind (N) = N_Extended_Return_Statement);
pragma Assert (Nkind_In (N, N_Simple_Return_Statement,
N_Extended_Return_Statement));
Returns_Object : constant Boolean :=
Nkind (N) = N_Extended_Return_Statement
@ -914,14 +907,16 @@ package body Sem_Ch6 is
Par : constant Node_Id := Parent (N);
begin
if (Nkind (Par) = N_Function_Call and then N = Name (Par))
if (Nkind (Par) = N_Function_Call
and then N = Name (Par))
or else Nkind (Par) = N_Function_Instantiation
or else (Nkind (Par) = N_Indexed_Component and then N = Prefix (Par))
or else (Nkind (Par) = N_Indexed_Component
and then N = Prefix (Par))
or else (Nkind (Par) = N_Pragma_Argument_Association
and then not Is_Pragma_String_Literal (Par))
or else Nkind (Par) = N_Subprogram_Renaming_Declaration
or else (Nkind (Par) = N_Attribute_Reference
and then Attribute_Name (Par) /= Name_Value)
or else (Nkind (Par) = N_Attribute_Reference
and then Attribute_Name (Par) /= Name_Value)
then
Find_Direct_Name (N);
@ -1463,7 +1458,7 @@ package body Sem_Ch6 is
Write_Eol;
end if;
Trace_Scope (N, Body_Id, " Analyze subprogram");
Trace_Scope (N, Body_Id, " Analyze subprogram: ");
-- Generic subprograms are handled separately. They always have a
-- generic specification. Determine whether current scope has a
@ -1945,7 +1940,7 @@ package body Sem_Ch6 is
elsif Present (Spec_Id)
and then Expander_Active
and then
(Is_Always_Inlined (Spec_Id)
(Has_Pragma_Inline_Always (Spec_Id)
or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining))
then
Build_Body_To_Inline (N, Spec_Id);
@ -2092,13 +2087,14 @@ package body Sem_Ch6 is
-- initialized!
declare
Stm : Node_Id := First (Statements (HSS));
Stm : Node_Id;
begin
-- Skip initial labels (for one thing this occurs when we are in
-- front end ZCX mode, but in any case it is irrelevant), and also
-- initial Push_xxx_Error_Label nodes, which are also irrelevant.
Stm := First (Statements (HSS));
while Nkind (Stm) = N_Label
or else Nkind (Stm) in N_Push_xxx_Label
loop
@ -2212,7 +2208,7 @@ package body Sem_Ch6 is
Trace_Scope
(N,
Defining_Entity (N),
" Analyze subprogram spec. ");
" Analyze subprogram spec: ");
if Debug_Flag_C then
Write_Str ("==== Compiling subprogram spec ");
@ -2355,8 +2351,7 @@ package body Sem_Ch6 is
Set_Etype (Designator, Standard_Void_Type);
end if;
-- Introduce new scope for analysis of the formals and of the
-- return type.
-- Introduce new scope for analysis of the formals and the return type
Set_Scope (Designator, Current_Scope);
@ -2495,12 +2490,10 @@ package body Sem_Ch6 is
then
Conv := Current_Entity (Id);
elsif (Nkind (Id) = N_Selected_Component
or else Nkind (Id) = N_Expanded_Name)
elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name)
and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion
then
Conv := Current_Entity (Selector_Name (Id));
else
return False;
end if;
@ -2515,16 +2508,15 @@ package body Sem_Ch6 is
begin
D := First (Decls);
while Present (D) loop
if (Nkind (D) = N_Function_Instantiation
and then not Is_Unchecked_Conversion (D))
or else Nkind (D) = N_Protected_Type_Declaration
or else Nkind (D) = N_Package_Declaration
or else Nkind (D) = N_Package_Instantiation
or else Nkind (D) = N_Subprogram_Body
or else Nkind (D) = N_Procedure_Instantiation
or else Nkind (D) = N_Task_Type_Declaration
if (Nkind (D) = N_Function_Instantiation
and then not Is_Unchecked_Conversion (D))
or else Nkind_In (D, N_Protected_Type_Declaration,
N_Package_Declaration,
N_Package_Instantiation,
N_Subprogram_Body,
N_Procedure_Instantiation,
N_Task_Type_Declaration)
then
Cannot_Inline
("cannot inline & (non-allowed declaration)?", D, Subp);
@ -2550,13 +2542,13 @@ package body Sem_Ch6 is
while Present (S) loop
Stat_Count := Stat_Count + 1;
if Nkind (S) = N_Abort_Statement
or else Nkind (S) = N_Asynchronous_Select
or else Nkind (S) = N_Conditional_Entry_Call
or else Nkind (S) = N_Delay_Relative_Statement
or else Nkind (S) = N_Delay_Until_Statement
or else Nkind (S) = N_Selective_Accept
or else Nkind (S) = N_Timed_Entry_Call
if Nkind_In (S, N_Abort_Statement,
N_Asynchronous_Select,
N_Conditional_Entry_Call,
N_Delay_Relative_Statement,
N_Delay_Until_Statement,
N_Selective_Accept,
N_Timed_Entry_Call)
then
Cannot_Inline
("cannot inline & (non-allowed statement)?", S, Subp);
@ -2821,7 +2813,7 @@ package body Sem_Ch6 is
-- checks on inlining (forbidden declarations, handlers, etc).
if Stat_Count > Max_Size
and then not Is_Always_Inlined (Subp)
and then not Has_Pragma_Inline_Always (Subp)
then
Cannot_Inline ("cannot inline& (body too large)?", N, Subp);
return;
@ -2917,7 +2909,7 @@ package body Sem_Ch6 is
then
null;
elsif Is_Always_Inlined (Subp) then
elsif Has_Pragma_Inline_Always (Subp) then
-- Remove last character (question mark) to make this into an error,
-- because the Inline_Always pragma cannot be obeyed.
@ -3828,11 +3820,11 @@ package body Sem_Ch6 is
Decl := Unit_Declaration_Node (Subp);
end if;
if Nkind (Decl) = N_Subprogram_Body
or else Nkind (Decl) = N_Subprogram_Body_Stub
or else Nkind (Decl) = N_Subprogram_Declaration
or else Nkind (Decl) = N_Abstract_Subprogram_Declaration
or else Nkind (Decl) = N_Subprogram_Renaming_Declaration
if Nkind_In (Decl, N_Subprogram_Body,
N_Subprogram_Body_Stub,
N_Subprogram_Declaration,
N_Abstract_Subprogram_Declaration,
N_Subprogram_Renaming_Declaration)
then
Spec := Specification (Decl);
@ -3864,7 +3856,7 @@ package body Sem_Ch6 is
-- argument the signature that may match that of a standard operation.
elsif Nkind (Subp) = N_Defining_Operator_Symbol
and then Must_Not_Override (Spec)
and then Must_Not_Override (Spec)
then
if Operator_Matches_Spec (Subp, Subp) then
Error_Msg_NE
@ -4023,9 +4015,9 @@ package body Sem_Ch6 is
-- Don't count exception junk
or else
((Nkind (Last_Stm) = N_Goto_Statement
or else Nkind (Last_Stm) = N_Label
or else Nkind (Last_Stm) = N_Object_Declaration)
(Nkind_In (Last_Stm, N_Goto_Statement,
N_Label,
N_Object_Declaration)
and then Exception_Junk (Last_Stm))
or else Nkind (Last_Stm) in N_Push_xxx_Label
or else Nkind (Last_Stm) in N_Pop_xxx_Label
@ -4111,7 +4103,6 @@ package body Sem_Ch6 is
elsif Kind = N_Case_Statement then
declare
Case_Alt : Node_Id;
begin
Case_Alt := First_Non_Pragma (Alternatives (Last_Stm));
while Present (Case_Alt) loop
@ -4247,12 +4238,15 @@ package body Sem_Ch6 is
-- Otherwise we have the case of a procedure marked No_Return
else
Error_Msg_N
("?implied return after this statement will raise Program_Error",
Last_Stm);
Error_Msg_NE
("?procedure & is marked as No_Return",
Last_Stm, Proc);
if not Raise_Exception_Call then
Error_Msg_N
("?implied return after this statement " &
"will raise Program_Error",
Last_Stm);
Error_Msg_NE
("\?procedure & is marked as No_Return!",
Last_Stm, Proc);
end if;
declare
RE : constant Node_Id :=
@ -4574,7 +4568,7 @@ package body Sem_Ch6 is
Are_Anonymous_Access_To_Subprogram_Types :=
Ekind (Type_1) = Ekind (Type_2)
and then
(Ekind (Type_1) = E_Anonymous_Access_Subprogram_Type
(Ekind (Type_1) = E_Anonymous_Access_Subprogram_Type
or else
Ekind (Type_1) = E_Anonymous_Access_Protected_Subprogram_Type);
@ -6146,9 +6140,8 @@ package body Sem_Ch6 is
then
return True;
elsif (Nkind (N) = N_Private_Type_Declaration
or else
Nkind (N) = N_Private_Extension_Declaration)
elsif Nkind_In (N, N_Private_Type_Declaration,
N_Private_Extension_Declaration)
and then Present (Defining_Identifier (N))
and then T = Full_View (Defining_Identifier (N))
then
@ -6303,9 +6296,10 @@ package body Sem_Ch6 is
-- operation in a type derivation on for a generic actual.
if Nkind (Parent (Typ)) /= N_Full_Type_Declaration
and then Nkind (Parent (Def_Id)) /= N_Subtype_Declaration
and then Nkind (Parent (Def_Id)) /= N_Task_Type_Declaration
and then Nkind (Parent (Def_Id)) /= N_Protected_Type_Declaration
and then
not Nkind_In (Parent (Def_Id), N_Subtype_Declaration,
N_Task_Type_Declaration,
N_Protected_Type_Declaration)
then
Collect_Abstract_Interfaces (Typ, Ifaces_List);
@ -6838,6 +6832,10 @@ package body Sem_Ch6 is
Default : Node_Id;
Ptype : Entity_Id;
-- The following are used for setting Is_Only_Out_
Num_Out_Params : Nat := 0;
First_Out_Param : Entity_Id := Empty;
function Is_Class_Wide_Default (D : Node_Id) return Boolean;
-- Check whether the default has a class-wide type. After analysis the
-- default has the type of the formal, so we must also check explicitly
@ -6895,8 +6893,8 @@ package body Sem_Ch6 is
elsif Is_Value_Type (Formal_Type) then
null;
elsif Nkind (Parent (T)) /= N_Access_Function_Definition
and then Nkind (Parent (T)) /= N_Access_Procedure_Definition
elsif not Nkind_In (Parent (T), N_Access_Function_Definition,
N_Access_Procedure_Definition)
then
Error_Msg_N ("invalid use of incomplete type", Param_Spec);
@ -7075,10 +7073,24 @@ package body Sem_Ch6 is
Apply_Scalar_Range_Check (Default, Formal_Type);
end if;
end if;
elsif Ekind (Formal) = E_Out_Parameter then
Num_Out_Params := Num_Out_Params + 1;
if Num_Out_Params = 1 then
First_Out_Param := Formal;
end if;
elsif Ekind (Formal) = E_In_Out_Parameter then
Num_Out_Params := Num_Out_Params + 1;
end if;
Next (Param_Spec);
end loop;
if Present (First_Out_Param) and then Num_Out_Params = 1 then
Set_Is_Only_Out_Parameter (First_Out_Param);
end if;
end Process_Formals;
----------------------------

10
gcc/ada/sem_ch6.ads
View File

@ -176,6 +176,16 @@ package Sem_Ch6 is
-- access parameter are attached to the Related_Nod which comes from the
-- context.
procedure Reference_Body_Formals (Spec : Entity_Id; Bod : Entity_Id);
-- If there is a separate spec for a subprogram or generic subprogram, the
-- formals of the body are treated as references to the corresponding
-- formals of the spec. This reference does not count as an actual use of
-- the formal, in order to diagnose formals that are unused in the body.
-- This procedure is also used in renaming_as_body declarations, where
-- the formals of the specification must be treated as body formals that
-- correspond to the previous subprogram declaration, and not as new
-- entities with their defining entry in the cross-reference information.
procedure Set_Actual_Subtypes (N : Node_Id; Subp : Entity_Id);
-- If the formals of a subprogram are unconstrained, build a subtype
-- declaration that uses the bounds or discriminants of the actual to