Skip to content

R
riscv-gcc-1
Commit 8fde064e by Arnaud Charlet
Options

[multiple changes] 

2013-04-11  Robert Dewar  <dewar@adacore.com>

	* errout.ads: Minor reformatting.
	* sem_eval.adb (Why_Not_Static): Now issues continuation messages
	(Why_Not_Static): Test for aggregates behind string literals.
	* sem_eval.ads (Why_Not_Static): Now issues continuation messages.

2013-04-11  Robert Dewar  <dewar@adacore.com>

	* exp_ch4.adb (Expand_Concatenation): Wrap expansion in
	Expressions_With_Actions.

2013-04-11  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Base_Types_Match): For an actual type in an
	instance, the base type may itself be a subtype, so find true
	base type to determine compatibility.

From-SVN: r197745
parent 354c3840
Showing with 285 additions and 193 deletions
gcc/ada/ChangeLog
2013-04-11 Robert Dewar <dewar@adacore.com> 2013-04-11 Robert Dewar <dewar@adacore.com>
* errout.ads: Minor reformatting.
* sem_eval.adb (Why_Not_Static): Now issues continuation messages
(Why_Not_Static): Test for aggregates behind string literals.
* sem_eval.ads (Why_Not_Static): Now issues continuation messages.
2013-04-11 Robert Dewar <dewar@adacore.com>
* exp_ch4.adb (Expand_Concatenation): Wrap expansion in
Expressions_With_Actions.
2013-04-11 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Base_Types_Match): For an actual type in an
instance, the base type may itself be a subtype, so find true
base type to determine compatibility.
2013-04-11 Robert Dewar <dewar@adacore.com>
* s-osprim-mingw.adb, sem_ch3.adb, sem_prag.adb, sem_util.adb. * s-osprim-mingw.adb, sem_ch3.adb, sem_prag.adb, sem_util.adb.
makeutl.adb, sem_ch8.adb: Minor reformatting. makeutl.adb, sem_ch8.adb: Minor reformatting.
......
gcc/ada/errout.ads
...@@ -242,7 +242,7 @@ package Errout is ...@@ -242,7 +242,7 @@ package Errout is
-- messages starting with the \ insertion character). The effect of the -- messages starting with the \ insertion character). The effect of the
-- use of ! in a parent message automatically applies to all of its -- use of ! in a parent message automatically applies to all of its
-- continuation messages (since we clearly don't want any case in which -- continuation messages (since we clearly don't want any case in which
-- continuations are separated from the parent message. It is allowable -- continuations are separated from the main message). It is allowable
-- to put ! in continuation messages, and the usual style is to include -- to put ! in continuation messages, and the usual style is to include
-- it, since it makes it clear that the continuation is part of an -- it, since it makes it clear that the continuation is part of an
-- unconditional message. -- unconditional message.
......
gcc/ada/exp_ch4.adb
...@@ -3017,6 +3017,8 @@ package body Exp_Ch4 is ...@@ -3017,6 +3017,8 @@ package body Exp_Ch4 is
-- Start of processing for Expand_Concatenate -- Start of processing for Expand_Concatenate
-- Kirtchev
begin begin
-- Choose an appropriate computational type -- Choose an appropriate computational type
...@@ -3233,7 +3235,6 @@ package body Exp_Ch4 is ...@@ -3233,7 +3235,6 @@ package body Exp_Ch4 is
Prefix => Prefix =>
Duplicate_Subexpr (Opnd, Name_Req => True), Duplicate_Subexpr (Opnd, Name_Req => True),
Attribute_Name => Name_First); Attribute_Name => Name_First);
Set_Parent (Opnd_Low_Bound (NN), Opnd);
-- Capture last operand bounds if result could be null -- Capture last operand bounds if result could be null
...@@ -3244,7 +3245,6 @@ package body Exp_Ch4 is ...@@ -3244,7 +3245,6 @@ package body Exp_Ch4 is
Prefix => Prefix =>
Duplicate_Subexpr (Opnd, Name_Req => True), Duplicate_Subexpr (Opnd, Name_Req => True),
Attribute_Name => Name_First)); Attribute_Name => Name_First));
Set_Parent (Last_Opnd_Low_Bound, Opnd);
Last_Opnd_High_Bound := Last_Opnd_High_Bound :=
Convert_To (Ityp, Convert_To (Ityp,
...@@ -3252,7 +3252,6 @@ package body Exp_Ch4 is ...@@ -3252,7 +3252,6 @@ package body Exp_Ch4 is
Prefix => Prefix =>
Duplicate_Subexpr (Opnd, Name_Req => True), Duplicate_Subexpr (Opnd, Name_Req => True),
Attribute_Name => Name_Last)); Attribute_Name => Name_Last));
Set_Parent (Last_Opnd_High_Bound, Opnd);
end if; end if;
-- Capture length of operand in entity -- Capture length of operand in entity
...@@ -5182,6 +5181,10 @@ package body Exp_Ch4 is ...@@ -5182,6 +5181,10 @@ package body Exp_Ch4 is
Desig_Typ := Obj_Typ; Desig_Typ := Obj_Typ;
end if; end if;
-- Kirtchev J730-020
Desig_Typ := Base_Type (Desig_Typ);
-- Generate: -- Generate:
-- Ann : access [all] <Desig_Typ>; -- Ann : access [all] <Desig_Typ>;
...@@ -6721,6 +6724,8 @@ package body Exp_Ch4 is ...@@ -6721,6 +6724,8 @@ package body Exp_Ch4 is
-- Node which is to be replaced by the result of concatenating the nodes -- Node which is to be replaced by the result of concatenating the nodes
-- in the list Opnds. -- in the list Opnds.
-- Kirtchev
begin begin
-- Ensure validity of both operands -- Ensure validity of both operands
...@@ -6748,7 +6753,6 @@ package body Exp_Ch4 is ...@@ -6748,7 +6753,6 @@ package body Exp_Ch4 is
-- Now Cnode is the deepest concatenation, and its parents are the -- Now Cnode is the deepest concatenation, and its parents are the
-- concatenation nodes above, so now we process bottom up, doing the -- concatenation nodes above, so now we process bottom up, doing the
-- operations. We gather a string that is as long as possible up to five
-- operands. -- operands.
-- The outer loop runs more than once if more than one concatenation -- The outer loop runs more than once if more than one concatenation
...@@ -6768,7 +6772,27 @@ package body Exp_Ch4 is ...@@ -6768,7 +6772,27 @@ package body Exp_Ch4 is
Append (Right_Opnd (Cnode), Opnds); Append (Right_Opnd (Cnode), Opnds);
end loop Inner; end loop Inner;
Expand_Concatenate (Cnode, Opnds); -- Wrap the node to concatenate into an expression actions node to
-- keep it nicely packaged. This is useful in the case of an assert
-- pragma with a concatenation where we want to be able to delete
-- the concatenation and all its expansion stuff.
declare
Cnod : constant Node_Id := Relocate_Node (Cnode);
Typ : constant Entity_Id := Base_Type (Etype (Cnode));
begin
-- Note: use Rewrite rather than Replace here, so that for example
-- Why_Not_Static can find the original concatenation node OK!
Rewrite (Cnode,
Make_Expression_With_Actions (Sloc (Cnode),
Actions => New_List (Make_Null_Statement (Sloc (Cnode))),
Expression => Cnod));
Expand_Concatenate (Cnod, Opnds);
Analyze_And_Resolve (Cnode, Typ);
end;
exit Outer when Cnode = N; exit Outer when Cnode = N;
Cnode := Parent (Cnode); Cnode := Parent (Cnode);
......
gcc/ada/sem_ch6.adb
...@@ -362,9 +362,7 @@ package body Sem_Ch6 is ...@@ -362,9 +362,7 @@ package body Sem_Ch6 is
Analyze (New_Body); Analyze (New_Body);
Set_Is_Inlined (Prev); Set_Is_Inlined (Prev);
elsif Present (Prev) elsif Present (Prev) and then Comes_From_Source (Prev) then
and then Comes_From_Source (Prev)
then
Set_Has_Completion (Prev, False); Set_Has_Completion (Prev, False);
-- For navigation purposes, indicate that the function is a body -- For navigation purposes, indicate that the function is a body
...@@ -436,9 +434,9 @@ package body Sem_Ch6 is ...@@ -436,9 +434,9 @@ package body Sem_Ch6 is
begin begin
if Nkind (Par) = N_Package_Specification if Nkind (Par) = N_Package_Specification
and then Decls = Visible_Declarations (Par) and then Decls = Visible_Declarations (Par)
and then Present (Private_Declarations (Par)) and then Present (Private_Declarations (Par))
and then not Is_Empty_List (Private_Declarations (Par)) and then not Is_Empty_List (Private_Declarations (Par))
then then
Decls := Private_Declarations (Par); Decls := Private_Declarations (Par);
end if; end if;
...@@ -882,7 +880,7 @@ package body Sem_Ch6 is ...@@ -882,7 +880,7 @@ package body Sem_Ch6 is
if Present (Expr) if Present (Expr)
-- Defend against previous errors -- Defend against previous errors
and then Nkind (Expr) /= N_Empty and then Nkind (Expr) /= N_Empty
and then Present (Etype (Expr)) and then Present (Etype (Expr))
...@@ -1220,7 +1218,7 @@ package body Sem_Ch6 is ...@@ -1220,7 +1218,7 @@ package body Sem_Ch6 is
begin begin
if (Nkind (Par) = N_Function_Call if (Nkind (Par) = N_Function_Call
and then N = Name (Par)) and then N = Name (Par))
or else Nkind (Par) = N_Function_Instantiation or else Nkind (Par) = N_Function_Instantiation
or else (Nkind (Par) = N_Indexed_Component or else (Nkind (Par) = N_Indexed_Component
and then N = Prefix (Par)) and then N = Prefix (Par))
...@@ -1322,8 +1320,8 @@ package body Sem_Ch6 is ...@@ -1322,8 +1320,8 @@ package body Sem_Ch6 is
-- Special processing for Elab_Spec, Elab_Body and Elab_Subp_Body calls -- Special processing for Elab_Spec, Elab_Body and Elab_Subp_Body calls
if Nkind (P) = N_Attribute_Reference if Nkind (P) = N_Attribute_Reference
and then (Attribute_Name (P) = Name_Elab_Spec or else and then (Attribute_Name (P) = Name_Elab_Spec or else
Attribute_Name (P) = Name_Elab_Body or else Attribute_Name (P) = Name_Elab_Body or else
Attribute_Name (P) = Name_Elab_Subp_Body) Attribute_Name (P) = Name_Elab_Subp_Body)
then then
if Present (Actuals) then if Present (Actuals) then
...@@ -1410,11 +1408,9 @@ package body Sem_Ch6 is ...@@ -1410,11 +1408,9 @@ package body Sem_Ch6 is
-- function, the context will select the operation whose type is Void. -- function, the context will select the operation whose type is Void.
elsif Nkind (P) = N_Selected_Component elsif Nkind (P) = N_Selected_Component
and then (Ekind (Entity (Selector_Name (P))) = E_Entry and then Ekind_In (Entity (Selector_Name (P)), E_Entry,
or else E_Procedure,
Ekind (Entity (Selector_Name (P))) = E_Procedure E_Function)
or else
Ekind (Entity (Selector_Name (P))) = E_Function)
then then
Analyze_Call_And_Resolve; Analyze_Call_And_Resolve;
...@@ -1490,8 +1486,8 @@ package body Sem_Ch6 is ...@@ -1490,8 +1486,8 @@ package body Sem_Ch6 is
Returns_Object : constant Boolean := Returns_Object : constant Boolean :=
Nkind (N) = N_Extended_Return_Statement Nkind (N) = N_Extended_Return_Statement
or else or else
(Nkind (N) = N_Simple_Return_Statement (Nkind (N) = N_Simple_Return_Statement
and then Present (Expression (N))); and then Present (Expression (N)));
-- True if we're returning something; that is, "return <expression>;" -- True if we're returning something; that is, "return <expression>;"
-- or "return Result : T [:= ...]". False for "return;". Used for error -- or "return Result : T [:= ...]". False for "return;". Used for error
-- checking: If Returns_Object is True, N should apply to a function -- checking: If Returns_Object is True, N should apply to a function
...@@ -1685,9 +1681,7 @@ package body Sem_Ch6 is ...@@ -1685,9 +1681,7 @@ package body Sem_Ch6 is
-- Unconstrained array as result is not allowed in SPARK -- Unconstrained array as result is not allowed in SPARK
if Is_Array_Type (Typ) if Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
and then not Is_Constrained (Typ)
then
Check_SPARK_Restriction Check_SPARK_Restriction
("returning an unconstrained array is not allowed", ("returning an unconstrained array is not allowed",
Result_Definition (N)); Result_Definition (N));
...@@ -1703,9 +1697,7 @@ package body Sem_Ch6 is ...@@ -1703,9 +1697,7 @@ package body Sem_Ch6 is
-- right before this, because they don't get applied to types that -- right before this, because they don't get applied to types that
-- do not come from source. -- do not come from source.
if Is_Access_Type (Typ) if Is_Access_Type (Typ) and then Null_Exclusion_Present (N) then
and then Null_Exclusion_Present (N)
then
Set_Etype (Designator, Set_Etype (Designator,
Create_Null_Excluding_Itype Create_Null_Excluding_Itype
(T => Typ, (T => Typ,
...@@ -1752,8 +1744,7 @@ package body Sem_Ch6 is ...@@ -1752,8 +1744,7 @@ package body Sem_Ch6 is
elsif Ekind (Typ) = E_Incomplete_Type elsif Ekind (Typ) = E_Incomplete_Type
or else (Is_Class_Wide_Type (Typ) or else (Is_Class_Wide_Type (Typ)
and then and then Ekind (Root_Type (Typ)) = E_Incomplete_Type)
Ekind (Root_Type (Typ)) = E_Incomplete_Type)
then then
-- AI05-0151: Tagged incomplete types are allowed in all formal -- AI05-0151: Tagged incomplete types are allowed in all formal
-- parts. Untagged incomplete types are not allowed in bodies. -- parts. Untagged incomplete types are not allowed in bodies.
...@@ -1952,7 +1943,7 @@ package body Sem_Ch6 is ...@@ -1952,7 +1943,7 @@ package body Sem_Ch6 is
Is_Limited_Record (Designated_Type (Etype (Scop))))) Is_Limited_Record (Designated_Type (Etype (Scop)))))
and then Expander_Active and then Expander_Active
-- Avoid cases with no tasking support -- Avoid cases with no tasking support
and then RTE_Available (RE_Current_Master) and then RTE_Available (RE_Current_Master)
and then not Restriction_Active (No_Task_Hierarchy) and then not Restriction_Active (No_Task_Hierarchy)
...@@ -2019,14 +2010,14 @@ package body Sem_Ch6 is ...@@ -2019,14 +2010,14 @@ package body Sem_Ch6 is
return return
Nkind (N) = N_Pragma Nkind (N) = N_Pragma
and then and then
(Pragma_Name (N) = Name_Inline_Always (Pragma_Name (N) = Name_Inline_Always
or else or else
(Front_End_Inlining (Front_End_Inlining
and then Pragma_Name (N) = Name_Inline)) and then Pragma_Name (N) = Name_Inline))
and then and then
Chars Chars
(Expression (First (Pragma_Argument_Associations (N)))) (Expression (First (Pragma_Argument_Associations (N)))) =
= Chars (Body_Id); Chars (Body_Id);
end Is_Inline_Pragma; end Is_Inline_Pragma;
-- Start of processing for Check_Inline_Pragma -- Start of processing for Check_Inline_Pragma
...@@ -2490,9 +2481,7 @@ package body Sem_Ch6 is ...@@ -2490,9 +2481,7 @@ package body Sem_Ch6 is
-- part of the context of one of its subunits. No need to redo the -- part of the context of one of its subunits. No need to redo the
-- analysis. -- analysis.
elsif Prev_Id = Body_Id elsif Prev_Id = Body_Id and then Has_Completion (Body_Id) then
and then Has_Completion (Body_Id)
then
return; return;
else else
...@@ -2658,8 +2647,8 @@ package body Sem_Ch6 is ...@@ -2658,8 +2647,8 @@ package body Sem_Ch6 is
(Nkind (Original_Node (Spec_Decl)) = (Nkind (Original_Node (Spec_Decl)) =
N_Subprogram_Renaming_Declaration N_Subprogram_Renaming_Declaration
or else (Present (Corresponding_Body (Spec_Decl)) or else (Present (Corresponding_Body (Spec_Decl))
and then and then
Nkind (Unit_Declaration_Node Nkind (Unit_Declaration_Node
(Corresponding_Body (Spec_Decl))) = (Corresponding_Body (Spec_Decl))) =
N_Subprogram_Renaming_Declaration)) N_Subprogram_Renaming_Declaration))
then then
...@@ -2821,9 +2810,7 @@ package body Sem_Ch6 is ...@@ -2821,9 +2810,7 @@ package body Sem_Ch6 is
-- is the limited view of a class-wide type and the non-limited view is -- is the limited view of a class-wide type and the non-limited view is
-- available, update the return type accordingly. -- available, update the return type accordingly.
if Ada_Version >= Ada_2005 if Ada_Version >= Ada_2005 and then Comes_From_Source (N) then
and then Comes_From_Source (N)
then
declare declare
Etyp : Entity_Id; Etyp : Entity_Id;
Rtyp : Entity_Id; Rtyp : Entity_Id;
...@@ -2834,9 +2821,7 @@ package body Sem_Ch6 is ...@@ -2834,9 +2821,7 @@ package body Sem_Ch6 is
if Ekind (Rtyp) = E_Anonymous_Access_Type then if Ekind (Rtyp) = E_Anonymous_Access_Type then
Etyp := Directly_Designated_Type (Rtyp); Etyp := Directly_Designated_Type (Rtyp);
if Is_Class_Wide_Type (Etyp) if Is_Class_Wide_Type (Etyp) and then From_With_Type (Etyp) then
and then From_With_Type (Etyp)
then
Set_Directly_Designated_Type Set_Directly_Designated_Type
(Etype (Current_Scope), Available_View (Etyp)); (Etype (Current_Scope), Available_View (Etyp));
end if; end if;
...@@ -2898,7 +2883,7 @@ package body Sem_Ch6 is ...@@ -2898,7 +2883,7 @@ package body Sem_Ch6 is
and then Expander_Active and then Expander_Active
and then and then
(Has_Pragma_Inline_Always (Spec_Id) (Has_Pragma_Inline_Always (Spec_Id)
or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining)) or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining))
then then
Build_Body_To_Inline (N, Spec_Id); Build_Body_To_Inline (N, Spec_Id);
end if; end if;
...@@ -3373,7 +3358,7 @@ package body Sem_Ch6 is ...@@ -3373,7 +3358,7 @@ package body Sem_Ch6 is
if Is_Interface (Etyp) if Is_Interface (Etyp)
and then not Is_Abstract_Subprogram (Designator) and then not Is_Abstract_Subprogram (Designator)
and then not (Ekind (Designator) = E_Procedure and then not (Ekind (Designator) = E_Procedure
and then Null_Present (Specification (N))) and then Null_Present (Specification (N)))
then then
Error_Msg_Name_1 := Chars (Defining_Entity (N)); Error_Msg_Name_1 := Chars (Defining_Entity (N));
...@@ -3401,10 +3386,9 @@ package body Sem_Ch6 is ...@@ -3401,10 +3386,9 @@ package body Sem_Ch6 is
Set_Kill_Elaboration_Checks (Designator); Set_Kill_Elaboration_Checks (Designator);
end if; end if;
if Scop /= Standard_Standard if Scop /= Standard_Standard and then not Is_Child_Unit (Designator) then
and then not Is_Child_Unit (Designator)
then
Set_Categorization_From_Scope (Designator, Scop); Set_Categorization_From_Scope (Designator, Scop);
else else
-- For a compilation unit, check for library-unit pragmas -- For a compilation unit, check for library-unit pragmas
...@@ -3890,7 +3874,7 @@ package body Sem_Ch6 is ...@@ -3890,7 +3874,7 @@ package body Sem_Ch6 is
elsif No (Expression (N)) elsif No (Expression (N))
and then Nkind (Parent (Parent (N))) = and then Nkind (Parent (Parent (N))) =
N_Extended_Return_Statement N_Extended_Return_Statement
then then
return OK; return OK;
...@@ -3932,7 +3916,7 @@ package body Sem_Ch6 is ...@@ -3932,7 +3916,7 @@ package body Sem_Ch6 is
return Present (Declarations (N)) return Present (Declarations (N))
and then Present (First (Declarations (N))) and then Present (First (Declarations (N)))
and then Chars (Expression (Return_Statement)) = and then Chars (Expression (Return_Statement)) =
Chars (Defining_Identifier (First (Declarations (N)))); Chars (Defining_Identifier (First (Declarations (N))));
end if; end if;
end Has_Single_Return; end Has_Single_Return;
...@@ -4809,8 +4793,8 @@ package body Sem_Ch6 is ...@@ -4809,8 +4793,8 @@ package body Sem_Ch6 is
May_Inline : constant Boolean := May_Inline : constant Boolean :=
Has_Pragma_Inline_Always (Spec_Id) Has_Pragma_Inline_Always (Spec_Id)
or else (Has_Pragma_Inline (Spec_Id) or else (Has_Pragma_Inline (Spec_Id)
and then ((Optimization_Level > 0 and then ((Optimization_Level > 0
and then Ekind (Spec_Id) and then Ekind (Spec_Id)
= E_Function) = E_Function)
or else Front_End_Inlining)); or else Front_End_Inlining));
Body_To_Analyze : Node_Id; Body_To_Analyze : Node_Id;
...@@ -5493,10 +5477,9 @@ package body Sem_Ch6 is ...@@ -5493,10 +5477,9 @@ package body Sem_Ch6 is
if Ada_Version >= Ada_2005 if Ada_Version >= Ada_2005
and then Ekind (Etype (Old_Type)) = E_Anonymous_Access_Type and then Ekind (Etype (Old_Type)) = E_Anonymous_Access_Type
and then and then
(Can_Never_Be_Null (Old_Type) (Can_Never_Be_Null (Old_Type) /= Can_Never_Be_Null (New_Type)
/= Can_Never_Be_Null (New_Type) or else Is_Access_Constant (Etype (Old_Type)) /=
or else Is_Access_Constant (Etype (Old_Type)) Is_Access_Constant (Etype (New_Type)))
/= Is_Access_Constant (Etype (New_Type)))
then then
Conformance_Error ("\return type does not match!", New_Id); Conformance_Error ("\return type does not match!", New_Id);
return; return;
...@@ -5519,7 +5502,6 @@ package body Sem_Ch6 is ...@@ -5519,7 +5502,6 @@ package body Sem_Ch6 is
if Ctype >= Subtype_Conformant then if Ctype >= Subtype_Conformant then
if Convention (Old_Id) /= Convention (New_Id) then if Convention (Old_Id) /= Convention (New_Id) then
if not Is_Frozen (New_Id) then if not Is_Frozen (New_Id) then
null; null;
...@@ -5646,8 +5628,8 @@ package body Sem_Ch6 is ...@@ -5646,8 +5628,8 @@ package body Sem_Ch6 is
Access_Types_Match := Ada_Version >= Ada_2005 Access_Types_Match := Ada_Version >= Ada_2005
-- Ensure that this rule is only applied when New_Id is a -- Ensure that this rule is only applied when New_Id is a
-- renaming of Old_Id. -- renaming of Old_Id.
and then Nkind (Parent (Parent (New_Id))) = and then Nkind (Parent (Parent (New_Id))) =
N_Subprogram_Renaming_Declaration N_Subprogram_Renaming_Declaration
...@@ -5655,26 +5637,26 @@ package body Sem_Ch6 is ...@@ -5655,26 +5637,26 @@ package body Sem_Ch6 is
and then Present (Entity (Name (Parent (Parent (New_Id))))) and then Present (Entity (Name (Parent (Parent (New_Id)))))
and then Entity (Name (Parent (Parent (New_Id)))) = Old_Id and then Entity (Name (Parent (Parent (New_Id)))) = Old_Id
-- Now handle the allowed access-type case -- Now handle the allowed access-type case
and then Is_Access_Type (Old_Formal_Base) and then Is_Access_Type (Old_Formal_Base)
and then Is_Access_Type (New_Formal_Base) and then Is_Access_Type (New_Formal_Base)
-- The type kinds must match. The only exception occurs with -- The type kinds must match. The only exception occurs with
-- multiple generics of the form: -- multiple generics of the form:
-- generic generic -- generic generic
-- type F is private; type A is private; -- type F is private; type A is private;
-- type F_Ptr is access F; type A_Ptr is access A; -- type F_Ptr is access F; type A_Ptr is access A;
-- with proc F_P (X : F_Ptr); with proc A_P (X : A_Ptr); -- with proc F_P (X : F_Ptr); with proc A_P (X : A_Ptr);
-- package F_Pack is ... package A_Pack is -- package F_Pack is ... package A_Pack is
-- package F_Inst is -- package F_Inst is
-- new F_Pack (A, A_Ptr, A_P); -- new F_Pack (A, A_Ptr, A_P);
-- When checking for conformance between the parameters of A_P -- When checking for conformance between the parameters of A_P
-- and F_P, the type kinds of F_Ptr and A_Ptr will not match -- and F_P, the type kinds of F_Ptr and A_Ptr will not match
-- because the compiler has transformed A_Ptr into a subtype of -- because the compiler has transformed A_Ptr into a subtype of
-- F_Ptr. We catch this case in the code below. -- F_Ptr. We catch this case in the code below.
and then (Ekind (Old_Formal_Base) = Ekind (New_Formal_Base) and then (Ekind (Old_Formal_Base) = Ekind (New_Formal_Base)
or else or else
...@@ -5684,7 +5666,7 @@ package body Sem_Ch6 is ...@@ -5684,7 +5666,7 @@ package body Sem_Ch6 is
and then Etype (Etype (New_Formal_Base)) = and then Etype (Etype (New_Formal_Base)) =
Old_Formal_Base)) Old_Formal_Base))
and then Directly_Designated_Type (Old_Formal_Base) = and then Directly_Designated_Type (Old_Formal_Base) =
Directly_Designated_Type (New_Formal_Base) Directly_Designated_Type (New_Formal_Base)
and then ((Is_Itype (Old_Formal_Base) and then ((Is_Itype (Old_Formal_Base)
and then Can_Never_Be_Null (Old_Formal_Base)) and then Can_Never_Be_Null (Old_Formal_Base))
or else or else
...@@ -6116,17 +6098,13 @@ package body Sem_Ch6 is ...@@ -6116,17 +6098,13 @@ package body Sem_Ch6 is
-- done for delayed_freeze subprograms because the underlying -- done for delayed_freeze subprograms because the underlying
-- returned type may not be known yet (for private types) -- returned type may not be known yet (for private types)
if not Has_Delayed_Freeze (Designator) if not Has_Delayed_Freeze (Designator) and then Expander_Active then
and then Expander_Active
then
declare declare
Typ : constant Entity_Id := Etype (Designator); Typ : constant Entity_Id := Etype (Designator);
Utyp : constant Entity_Id := Underlying_Type (Typ); Utyp : constant Entity_Id := Underlying_Type (Typ);
begin begin
if Is_Immutably_Limited_Type (Typ) then if Is_Immutably_Limited_Type (Typ) then
Set_Returns_By_Ref (Designator); Set_Returns_By_Ref (Designator);
elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
Set_Returns_By_Ref (Designator); Set_Returns_By_Ref (Designator);
end if; end if;
...@@ -6190,7 +6168,7 @@ package body Sem_Ch6 is ...@@ -6190,7 +6168,7 @@ package body Sem_Ch6 is
-- with partial declaration. -- with partial declaration.
if Is_Access_Type (New_Discr_Type) if Is_Access_Type (New_Discr_Type)
and then Null_Exclusion_Present (New_Discr) and then Null_Exclusion_Present (New_Discr)
then then
New_Discr_Type := New_Discr_Type :=
Create_Null_Excluding_Itype Create_Null_Excluding_Itype
...@@ -6678,9 +6656,7 @@ package body Sem_Ch6 is ...@@ -6678,9 +6656,7 @@ package body Sem_Ch6 is
-- sequences (which were the original sequences of statements in -- sequences (which were the original sequences of statements in
-- the exception handlers) and check them. -- the exception handlers) and check them.
if Nkind (Last_Stm) = N_Label if Nkind (Last_Stm) = N_Label and then Exception_Junk (Last_Stm) then
and then Exception_Junk (Last_Stm)
then
Stm := Last_Stm; Stm := Last_Stm;
loop loop
Prev (Stm); Prev (Stm);
...@@ -6721,7 +6697,7 @@ package body Sem_Ch6 is ...@@ -6721,7 +6697,7 @@ package body Sem_Ch6 is
(Nkind_In (Last_Stm, N_Goto_Statement, (Nkind_In (Last_Stm, N_Goto_Statement,
N_Label, N_Label,
N_Object_Declaration) N_Object_Declaration)
and then Exception_Junk (Last_Stm)) and then Exception_Junk (Last_Stm))
or else Nkind (Last_Stm) in N_Push_xxx_Label or else Nkind (Last_Stm) in N_Push_xxx_Label
or else Nkind (Last_Stm) in N_Pop_xxx_Label or else Nkind (Last_Stm) in N_Pop_xxx_Label
...@@ -7511,11 +7487,14 @@ package body Sem_Ch6 is ...@@ -7511,11 +7487,14 @@ package body Sem_Ch6 is
---------------------- ----------------------
function Base_Types_Match (T1, T2 : Entity_Id) return Boolean is function Base_Types_Match (T1, T2 : Entity_Id) return Boolean is
BT1 : constant Entity_Id := Base_Type (T1);
BT2 : constant Entity_Id := Base_Type (T2);
begin begin
if T1 = T2 then if T1 = T2 then
return True; return True;
elsif Base_Type (T1) = Base_Type (T2) then elsif BT1 = BT2 then
-- The following is too permissive. A more precise test should -- The following is too permissive. A more precise test should
-- check that the generic actual is an ancestor subtype of the -- check that the generic actual is an ancestor subtype of the
...@@ -7528,6 +7507,16 @@ package body Sem_Ch6 is ...@@ -7528,6 +7507,16 @@ package body Sem_Ch6 is
or else not Is_Generic_Actual_Type (T2) or else not Is_Generic_Actual_Type (T2)
or else Scope (T1) /= Scope (T2); or else Scope (T1) /= Scope (T2);
-- If T2 is a generic actual type it is declared as the subtype of
-- the actual. If that actual is itself a subtype we need to use
-- its own base type to check for compatibility.
elsif Ekind (BT2) = Ekind (T2) and then BT1 = Base_Type (BT2) then
return True;
elsif Ekind (BT1) = Ekind (T1) and then BT2 = Base_Type (BT1) then
return True;
else else
return False; return False;
end if; end if;
...@@ -7572,14 +7561,10 @@ package body Sem_Ch6 is ...@@ -7572,14 +7561,10 @@ package body Sem_Ch6 is
-- access-to-class-wide type in a formal. Both entities designate the -- access-to-class-wide type in a formal. Both entities designate the
-- same type. -- same type.
if From_With_Type (T1) if From_With_Type (T1) and then T2 = Available_View (T1) then
and then T2 = Available_View (T1)
then
return True; return True;
elsif From_With_Type (T2) elsif From_With_Type (T2) and then T1 = Available_View (T2) then
and then T1 = Available_View (T2)
then
return True; return True;
elsif From_With_Type (T1) elsif From_With_Type (T1)
...@@ -7596,10 +7581,9 @@ package body Sem_Ch6 is ...@@ -7596,10 +7581,9 @@ package body Sem_Ch6 is
-- Start of processing for Conforming_Types -- Start of processing for Conforming_Types
begin begin
-- The context is an instance association for a formal -- The context is an instance association for a formal access-to-
-- access-to-subprogram type; the formal parameter types require -- subprogram type; the formal parameter types require mapping because
-- mapping because they may denote other formal parameters of the -- they may denote other formal parameters of the generic unit.
-- generic unit.
if Get_Inst then if Get_Inst then
Type_1 := Get_Instance_Of (T1); Type_1 := Get_Instance_Of (T1);
...@@ -7645,9 +7629,8 @@ package body Sem_Ch6 is ...@@ -7645,9 +7629,8 @@ package body Sem_Ch6 is
Are_Anonymous_Access_To_Subprogram_Types := Are_Anonymous_Access_To_Subprogram_Types :=
Ekind (Type_1) = Ekind (Type_2) Ekind (Type_1) = Ekind (Type_2)
and then and then
(Ekind (Type_1) = E_Anonymous_Access_Subprogram_Type Ekind_In (Type_1, E_Anonymous_Access_Subprogram_Type,
or else E_Anonymous_Access_Protected_Subprogram_Type);
Ekind (Type_1) = E_Anonymous_Access_Protected_Subprogram_Type);
-- Test anonymous access type case. For this case, static subtype -- Test anonymous access type case. For this case, static subtype
-- matching is required for mode conformance (RM 6.3.1(15)). We check -- matching is required for mode conformance (RM 6.3.1(15)). We check
...@@ -7657,7 +7640,10 @@ package body Sem_Ch6 is ...@@ -7657,7 +7640,10 @@ package body Sem_Ch6 is
if (Ekind (Base_Type (Type_1)) = E_Anonymous_Access_Type if (Ekind (Base_Type (Type_1)) = E_Anonymous_Access_Type
and then and then
Ekind (Base_Type (Type_2)) = E_Anonymous_Access_Type) Ekind (Base_Type (Type_2)) = E_Anonymous_Access_Type)
or else Are_Anonymous_Access_To_Subprogram_Types -- Ada 2005 (AI-254)
-- Ada 2005 (AI-254)
or else Are_Anonymous_Access_To_Subprogram_Types
then then
declare declare
Desig_1 : Entity_Id; Desig_1 : Entity_Id;
...@@ -7725,8 +7711,8 @@ package body Sem_Ch6 is ...@@ -7725,8 +7711,8 @@ package body Sem_Ch6 is
else else
return Base_Type (Desig_1) = Base_Type (Desig_2) return Base_Type (Desig_1) = Base_Type (Desig_2)
and then (Ctype = Type_Conformant and then (Ctype = Type_Conformant
or else or else
Subtypes_Statically_Match (Desig_1, Desig_2)); Subtypes_Statically_Match (Desig_1, Desig_2));
end if; end if;
end; end;
...@@ -7736,7 +7722,7 @@ package body Sem_Ch6 is ...@@ -7736,7 +7722,7 @@ package body Sem_Ch6 is
if ((Ekind (Type_1) = E_Anonymous_Access_Type if ((Ekind (Type_1) = E_Anonymous_Access_Type
and then Is_Access_Type (Type_2)) and then Is_Access_Type (Type_2))
or else (Ekind (Type_2) = E_Anonymous_Access_Type or else (Ekind (Type_2) = E_Anonymous_Access_Type
and then Is_Access_Type (Type_1))) and then Is_Access_Type (Type_1)))
and then and then
Conforming_Types Conforming_Types
(Designated_Type (Type_1), Designated_Type (Type_2), Ctype) (Designated_Type (Type_1), Designated_Type (Type_2), Ctype)
...@@ -7826,8 +7812,8 @@ package body Sem_Ch6 is ...@@ -7826,8 +7812,8 @@ package body Sem_Ch6 is
-- Start of processing for Create_Extra_Formals -- Start of processing for Create_Extra_Formals
begin begin
-- We never generate extra formals if expansion is not active -- We never generate extra formals if expansion is not active because we
-- because we don't need them unless we are generating code. -- don't need them unless we are generating code.
if not Expander_Active then if not Expander_Active then
return; return;
...@@ -7852,9 +7838,7 @@ package body Sem_Ch6 is ...@@ -7852,9 +7838,7 @@ package body Sem_Ch6 is
-- situation may arise for subprogram types created as part of -- situation may arise for subprogram types created as part of
-- dispatching calls (see Expand_Dispatching_Call) -- dispatching calls (see Expand_Dispatching_Call)
if Present (Last_Extra) and then if Present (Last_Extra) and then Present (Extra_Formal (Last_Extra)) then
Present (Extra_Formal (Last_Extra))
then
return; return;
end if; end if;
...@@ -8093,9 +8077,7 @@ package body Sem_Ch6 is ...@@ -8093,9 +8077,7 @@ package body Sem_Ch6 is
-- Chain new entity if front of homonym in current scope, so that -- Chain new entity if front of homonym in current scope, so that
-- homonyms are contiguous. -- homonyms are contiguous.
if Present (E) if Present (E) and then E /= C_E then
and then E /= C_E
then
while Homonym (C_E) /= E loop while Homonym (C_E) /= E loop
C_E := Homonym (C_E); C_E := Homonym (C_E);
end loop; end loop;
...@@ -8606,14 +8588,10 @@ package body Sem_Ch6 is ...@@ -8606,14 +8588,10 @@ package body Sem_Ch6 is
return Nkind (Selector_Name (E1)) = N_Character_Literal return Nkind (Selector_Name (E1)) = N_Character_Literal
and then Chars (E2) = Chars (Selector_Name (E1)); and then Chars (E2) = Chars (Selector_Name (E1));
elsif Nkind (E1) in N_Op elsif Nkind (E1) in N_Op and then Nkind (E2) = N_Function_Call then
and then Nkind (E2) = N_Function_Call
then
return FCO (E1, E2); return FCO (E1, E2);
elsif Nkind (E2) in N_Op elsif Nkind (E2) in N_Op and then Nkind (E1) = N_Function_Call then
and then Nkind (E1) = N_Function_Call
then
return FCO (E2, E1); return FCO (E2, E1);
-- Otherwise we must have the same syntactic entity -- Otherwise we must have the same syntactic entity
...@@ -9319,8 +9297,8 @@ package body Sem_Ch6 is ...@@ -9319,8 +9297,8 @@ package body Sem_Ch6 is
and then No (N_Formal) and then No (N_Formal)
and then (Ekind (New_E) /= E_Function and then (Ekind (New_E) /= E_Function
or else or else
Types_Correspond Types_Correspond
(Etype (P_Prim), Etype (New_E))) (Etype (P_Prim), Etype (New_E)))
then then
return False; return False;
end if; end if;
...@@ -9615,12 +9593,8 @@ package body Sem_Ch6 is ...@@ -9615,12 +9593,8 @@ package body Sem_Ch6 is
("abstract subprograms must be visible " ("abstract subprograms must be visible "
& "(RM 3.9.3(10))!", S); & "(RM 3.9.3(10))!", S);
elsif Ekind (S) = E_Function elsif Ekind (S) = E_Function and then not Is_Overriding then
and then not Is_Overriding if Is_Tagged_Type (T) and then T = Base_Type (Etype (S)) then
then
if Is_Tagged_Type (T)
and then T = Base_Type (Etype (S))
then
Error_Msg_N Error_Msg_N
("private function with tagged result must" ("private function with tagged result must"
& " override visible-part function", S); & " override visible-part function", S);
...@@ -10038,7 +10012,7 @@ package body Sem_Ch6 is ...@@ -10038,7 +10012,7 @@ package body Sem_Ch6 is
-- interface procedures. -- interface procedures.
elsif (Ekind (Def_Id) = E_Procedure elsif (Ekind (Def_Id) = E_Procedure
or else Ekind (Def_Id) = E_Entry) or else Ekind (Def_Id) = E_Entry)
and then Ekind (Subp) = E_Procedure and then Ekind (Subp) = E_Procedure
and then Matches_Prefixed_View_Profile and then Matches_Prefixed_View_Profile
(Parameter_Specifications (Parent (Def_Id)), (Parameter_Specifications (Parent (Def_Id)),
...@@ -10059,13 +10033,12 @@ package body Sem_Ch6 is ...@@ -10059,13 +10033,12 @@ package body Sem_Ch6 is
-- routine must be of mode "out", "in out" or -- routine must be of mode "out", "in out" or
-- access-to-variable. -- access-to-variable.
if (Ekind (Candidate) = E_Entry if Ekind_In (Candidate, E_Entry, E_Procedure)
or else Ekind (Candidate) = E_Procedure)
and then Is_Protected_Type (Typ) and then Is_Protected_Type (Typ)
and then Ekind (Formal) /= E_In_Out_Parameter and then Ekind (Formal) /= E_In_Out_Parameter
and then Ekind (Formal) /= E_Out_Parameter and then Ekind (Formal) /= E_Out_Parameter
and then Nkind (Parameter_Type (Parent (Formal))) and then Nkind (Parameter_Type (Parent (Formal))) /=
/= N_Access_Definition N_Access_Definition
then then
null; null;
...@@ -10453,9 +10426,7 @@ package body Sem_Ch6 is ...@@ -10453,9 +10426,7 @@ package body Sem_Ch6 is
begin begin
Prev := First_Entity (Current_Scope); Prev := First_Entity (Current_Scope);
while Present (Prev) while Present (Prev) and then Next_Entity (Prev) /= E loop
and then Next_Entity (Prev) /= E
loop
Next_Entity (Prev); Next_Entity (Prev);
end loop; end loop;
...@@ -10798,8 +10769,7 @@ package body Sem_Ch6 is ...@@ -10798,8 +10769,7 @@ package body Sem_Ch6 is
end if; end if;
return return
Ekind (Desig) = E_Incomplete_Type Ekind (Desig) = E_Incomplete_Type and then From_With_Type (Desig);
and then From_With_Type (Desig);
end Designates_From_With_Type; end Designates_From_With_Type;
--------------------------- ---------------------------
...@@ -10842,7 +10812,7 @@ package body Sem_Ch6 is ...@@ -10842,7 +10812,7 @@ package body Sem_Ch6 is
if Is_Incomplete_Type (Formal_Type) if Is_Incomplete_Type (Formal_Type)
or else or else
(Is_Class_Wide_Type (Formal_Type) (Is_Class_Wide_Type (Formal_Type)
and then Is_Incomplete_Type (Root_Type (Formal_Type))) and then Is_Incomplete_Type (Root_Type (Formal_Type)))
then then
-- Ada 2005 (AI-326): Tagged incomplete types allowed in -- Ada 2005 (AI-326): Tagged incomplete types allowed in
-- primitive operations, as long as their completion is -- primitive operations, as long as their completion is
...@@ -12515,9 +12485,7 @@ package body Sem_Ch6 is ...@@ -12515,9 +12485,7 @@ package body Sem_Ch6 is
-- If this is an empty initialization procedure, no need to create -- If this is an empty initialization procedure, no need to create
-- actual subtypes (small optimization). -- actual subtypes (small optimization).
if Ekind (Subp) = E_Procedure if Ekind (Subp) = E_Procedure and then Is_Null_Init_Proc (Subp) then
and then Is_Null_Init_Proc (Subp)
then
return; return;
end if; end if;
......
gcc/ada/sem_eval.adb
...@@ -5495,8 +5495,8 @@ package body Sem_Eval is ...@@ -5495,8 +5495,8 @@ package body Sem_Eval is
if Raises_Constraint_Error (Expr) then if Raises_Constraint_Error (Expr) then
Error_Msg_N Error_Msg_N
("expression raises exception, cannot be static " & ("\expression raises exception, cannot be static " &
"(RM 4.9(34))!", N); "(RM 4.9(34))", N);
return; return;
end if; end if;
...@@ -5516,8 +5516,8 @@ package body Sem_Eval is ...@@ -5516,8 +5516,8 @@ package body Sem_Eval is
and then not Is_RTE (Typ, RE_Bignum) and then not Is_RTE (Typ, RE_Bignum)
then then
Error_Msg_N Error_Msg_N
("static expression must have scalar or string type " & ("\static expression must have scalar or string type " &
"(RM 4.9(2))!", N); "(RM 4.9(2))", N);
return; return;
end if; end if;
end if; end if;
...@@ -5525,6 +5525,9 @@ package body Sem_Eval is ...@@ -5525,6 +5525,9 @@ package body Sem_Eval is
-- If we got through those checks, test particular node kind -- If we got through those checks, test particular node kind
case Nkind (N) is case Nkind (N) is
-- Entity name
when N_Expanded_Name | N_Identifier | N_Operator_Symbol => when N_Expanded_Name | N_Identifier | N_Operator_Symbol =>
E := Entity (N); E := Entity (N);
...@@ -5532,30 +5535,84 @@ package body Sem_Eval is ...@@ -5532,30 +5535,84 @@ package body Sem_Eval is
null; null;
elsif Ekind (E) = E_Constant then elsif Ekind (E) = E_Constant then
if not Is_Static_Expression (Constant_Value (E)) then
Error_Msg_NE -- One case we can give a metter message is when we have a
("& is not a static constant (RM 4.9(5))!", N, E); -- string literal created by concatenating an aggregate with
end if; -- an others expression.
Entity_Case : declare
CV : constant Node_Id := Constant_Value (E);
CO : constant Node_Id := Original_Node (CV);
function Is_Aggregate (N : Node_Id) return Boolean;
-- See if node N came from an others aggregate, if so
-- return True and set Error_Msg_Sloc to aggregate.
------------------
-- Is_Aggregate --
------------------
function Is_Aggregate (N : Node_Id) return Boolean is
begin
if Nkind (Original_Node (N)) = N_Aggregate then
Error_Msg_Sloc := Sloc (Original_Node (N));
return True;
elsif Is_Entity_Name (N)
and then Ekind (Entity (N)) = E_Constant
and then
Nkind (Original_Node (Constant_Value (Entity (N)))) =
N_Aggregate
then
Error_Msg_Sloc :=
Sloc (Original_Node (Constant_Value (Entity (N))));
return True;
else
return False;
end if;
end Is_Aggregate;
-- Start of processing for Entity_Case
begin
if Is_Aggregate (CV)
or else (Nkind (CO) = N_Op_Concat
and then (Is_Aggregate (Left_Opnd (CO))
or else
Is_Aggregate (Right_Opnd (CO))))
then
Error_Msg_N ("\aggregate (#) is never static", N);
elsif not Is_Static_Expression (CV) then
Error_Msg_NE
("\& is not a static constant (RM 4.9(5))", N, E);
end if;
end Entity_Case;
else else
Error_Msg_NE Error_Msg_NE
("& is not static constant or named number " & ("\& is not static constant or named number "
"(RM 4.9(5))!", N, E); & "(RM 4.9(5))", N, E);
end if; end if;
-- Binary operator
when N_Binary_Op | N_Short_Circuit | N_Membership_Test => when N_Binary_Op | N_Short_Circuit | N_Membership_Test =>
if Nkind (N) in N_Op_Shift then if Nkind (N) in N_Op_Shift then
Error_Msg_N Error_Msg_N
("shift functions are never static (RM 4.9(6,18))!", N); ("\shift functions are never static (RM 4.9(6,18))", N);
else else
Why_Not_Static (Left_Opnd (N)); Why_Not_Static (Left_Opnd (N));
Why_Not_Static (Right_Opnd (N)); Why_Not_Static (Right_Opnd (N));
end if; end if;
-- Unary operator
when N_Unary_Op => when N_Unary_Op =>
Why_Not_Static (Right_Opnd (N)); Why_Not_Static (Right_Opnd (N));
-- Attribute reference
when N_Attribute_Reference => when N_Attribute_Reference =>
Why_Not_Static_List (Expressions (N)); Why_Not_Static_List (Expressions (N));
...@@ -5569,8 +5626,8 @@ package body Sem_Eval is ...@@ -5569,8 +5626,8 @@ package body Sem_Eval is
if Attribute_Name (N) = Name_Size then if Attribute_Name (N) = Name_Size then
Error_Msg_N Error_Msg_N
("size attribute is only static for static scalar type " & ("\size attribute is only static for static scalar type "
"(RM 4.9(7,8))", N); & "(RM 4.9(7,8))", N);
-- Flag array cases -- Flag array cases
...@@ -5582,15 +5639,15 @@ package body Sem_Eval is ...@@ -5582,15 +5639,15 @@ package body Sem_Eval is
Attribute_Name (N) /= Name_Length Attribute_Name (N) /= Name_Length
then then
Error_Msg_N Error_Msg_N
("static array attribute must be Length, First, or Last " & ("\static array attribute must be Length, First, or Last "
"(RM 4.9(8))!", N); & "(RM 4.9(8))", N);
-- Since we know the expression is not-static (we already -- Since we know the expression is not-static (we already
-- tested for this, must mean array is not static). -- tested for this, must mean array is not static).
else else
Error_Msg_N Error_Msg_N
("prefix is non-static array (RM 4.9(8))!", Prefix (N)); ("\prefix is non-static array (RM 4.9(8))", Prefix (N));
end if; end if;
return; return;
...@@ -5603,30 +5660,36 @@ package body Sem_Eval is ...@@ -5603,30 +5660,36 @@ package body Sem_Eval is
Is_Generic_Type (E) Is_Generic_Type (E)
then then
Error_Msg_N Error_Msg_N
("attribute of generic type is never static " & ("\attribute of generic type is never static "
"(RM 4.9(7,8))!", N); & "(RM 4.9(7,8))", N);
elsif Is_Static_Subtype (E) then elsif Is_Static_Subtype (E) then
null; null;
elsif Is_Scalar_Type (E) then elsif Is_Scalar_Type (E) then
Error_Msg_N Error_Msg_N
("prefix type for attribute is not static scalar subtype " & ("\prefix type for attribute is not static scalar subtype "
"(RM 4.9(7))!", N); & "(RM 4.9(7))", N);
else else
Error_Msg_N Error_Msg_N
("static attribute must apply to array/scalar type " & ("\static attribute must apply to array/scalar type "
"(RM 4.9(7,8))!", N); & "(RM 4.9(7,8))", N);
end if; end if;
-- String literal
when N_String_Literal => when N_String_Literal =>
Error_Msg_N Error_Msg_N
("subtype of string literal is non-static (RM 4.9(4))!", N); ("\subtype of string literal is non-static (RM 4.9(4))", N);
-- Explicit dereference
when N_Explicit_Dereference => when N_Explicit_Dereference =>
Error_Msg_N Error_Msg_N
("explicit dereference is never static (RM 4.9)!", N); ("\explicit dereference is never static (RM 4.9)", N);
-- Function call
when N_Function_Call => when N_Function_Call =>
Why_Not_Static_List (Parameter_Associations (N)); Why_Not_Static_List (Parameter_Associations (N));
...@@ -5636,44 +5699,59 @@ package body Sem_Eval is ...@@ -5636,44 +5699,59 @@ package body Sem_Eval is
-- scalar arithmetic operation. -- scalar arithmetic operation.
if not Is_RTE (Typ, RE_Bignum) then if not Is_RTE (Typ, RE_Bignum) then
Error_Msg_N ("non-static function call (RM 4.9(6,18))!", N); Error_Msg_N ("\non-static function call (RM 4.9(6,18))", N);
end if; end if;
-- Parameter assocation (test actual parameter)
when N_Parameter_Association => when N_Parameter_Association =>
Why_Not_Static (Explicit_Actual_Parameter (N)); Why_Not_Static (Explicit_Actual_Parameter (N));
-- Indexed component
when N_Indexed_Component => when N_Indexed_Component =>
Error_Msg_N Error_Msg_N ("\indexed component is never static (RM 4.9)", N);
("indexed component is never static (RM 4.9)!", N);
-- Procedure call
when N_Procedure_Call_Statement => when N_Procedure_Call_Statement =>
Error_Msg_N Error_Msg_N ("\procedure call is never static (RM 4.9)", N);
("procedure call is never static (RM 4.9)!", N);
-- Qualified expression (test expression)
when N_Qualified_Expression => when N_Qualified_Expression =>
Why_Not_Static (Expression (N)); Why_Not_Static (Expression (N));
-- Aggregate
when N_Aggregate | N_Extension_Aggregate => when N_Aggregate | N_Extension_Aggregate =>
Error_Msg_N Error_Msg_N ("\an aggregate is never static (RM 4.9)", N);
("an aggregate is never static (RM 4.9)!", N);
-- Range
when N_Range => when N_Range =>
Why_Not_Static (Low_Bound (N)); Why_Not_Static (Low_Bound (N));
Why_Not_Static (High_Bound (N)); Why_Not_Static (High_Bound (N));
-- Range constraint, test range expression
when N_Range_Constraint => when N_Range_Constraint =>
Why_Not_Static (Range_Expression (N)); Why_Not_Static (Range_Expression (N));
-- Subtype indication, test constraint
when N_Subtype_Indication => when N_Subtype_Indication =>
Why_Not_Static (Constraint (N)); Why_Not_Static (Constraint (N));
-- Selected component
when N_Selected_Component => when N_Selected_Component =>
Error_Msg_N Error_Msg_N ("\selected component is never static (RM 4.9)", N);
("selected component is never static (RM 4.9)!", N);
-- Slice
when N_Slice => when N_Slice =>
Error_Msg_N Error_Msg_N ("\slice is never static (RM 4.9)", N);
("slice is never static (RM 4.9)!", N);
when N_Type_Conversion => when N_Type_Conversion =>
Why_Not_Static (Expression (N)); Why_Not_Static (Expression (N));
...@@ -5682,13 +5760,17 @@ package body Sem_Eval is ...@@ -5682,13 +5760,17 @@ package body Sem_Eval is
or else not Is_Static_Subtype (Entity (Subtype_Mark (N))) or else not Is_Static_Subtype (Entity (Subtype_Mark (N)))
then then
Error_Msg_N Error_Msg_N
("static conversion requires static scalar subtype result " & ("\static conversion requires static scalar subtype result "
"(RM 4.9(9))!", N); & "(RM 4.9(9))", N);
end if; end if;
-- Unchecked type conversion
when N_Unchecked_Type_Conversion => when N_Unchecked_Type_Conversion =>
Error_Msg_N Error_Msg_N
("unchecked type conversion is never static (RM 4.9)!", N); ("\unchecked type conversion is never static (RM 4.9)", N);
-- All other cases, no reason to give
when others => when others =>
null; null;
......
gcc/ada/sem_eval.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -417,17 +417,17 @@ package Sem_Eval is ...@@ -417,17 +417,17 @@ package Sem_Eval is
procedure Why_Not_Static (Expr : Node_Id); procedure Why_Not_Static (Expr : Node_Id);
-- This procedure may be called after generating an error message that -- This procedure may be called after generating an error message that
-- complains that something is non-static. If it finds good reasons, it -- complains that something is non-static. If it finds good reasons,
-- generates one or more error messages pointing the appropriate offending -- it generates one or more continuation error messages pointing the
-- component of the expression. If no good reasons can be figured out, then -- appropriate offending component of the expression. If no good reasons
-- no messages are generated. The expectation here is that the caller has -- can be figured out, then no messages are generated. The expectation here
-- already issued a message complaining that the expression is non-static. -- is that the caller has already issued a message complaining that the
-- Note that this message should be placed using Error_Msg_F or -- expression is non-static. Note that this message should be placed using
-- Error_Msg_FE, so that it will sort before any messages placed by this -- Error_Msg_F or Error_Msg_FE, so that it will sort before any messages
-- call. Note that it is fine to call Why_Not_Static with something that is -- placed by this call. Note that it is fine to call Why_Not_Static with
-- not an expression, and usually this has no effect, but in some cases -- something that is not an expression, and usually this has no effect, but
-- (N_Parameter_Association or N_Range), it makes sense for the internal -- in some cases (N_Parameter_Association or N_Range), it makes sense for
-- recursive calls. -- the internal recursive calls.
procedure Initialize; procedure Initialize;
-- Initializes the internal data structures. Must be called before each -- Initializes the internal data structures. Must be called before each
......
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