Commit e660dbf7 by Javier Miranda Committed by Arnaud Charlet

sem_ch6.adb (Check_Conformance): The null-exclusion feature can be omitted in…

sem_ch6.adb (Check_Conformance): The null-exclusion feature can be omitted in case of stream attribute subprograms.

2005-11-14  Javier Miranda  <miranda@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Check_Conformance): The null-exclusion feature can be
	omitted in case of stream attribute subprograms.
	(Check_Inline_Pragma): Handle Inline and Inline_Always pragmas that
	appear immediately after a subprogram body, when there is no previous
	subprogram declaration.
	Change name Is_Package to Is_Package_Or_Generic_Package
	(Process_Formals): A non null qualifier on a non null named access
	type is not an error, and is a warning only if Redundant_Constructs
	are flagged.

From-SVN: r107001
parent 950d3e7d
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2005, 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- --
...@@ -32,6 +32,7 @@ with Elists; use Elists; ...@@ -32,6 +32,7 @@ with Elists; use Elists;
with Errout; use Errout; with Errout; use Errout;
with Expander; use Expander; with Expander; use Expander;
with Exp_Ch7; use Exp_Ch7; with Exp_Ch7; use Exp_Ch7;
with Exp_Tss; use Exp_Tss;
with Fname; use Fname; with Fname; use Fname;
with Freeze; use Freeze; with Freeze; use Freeze;
with Itypes; use Itypes; with Itypes; use Itypes;
...@@ -236,7 +237,7 @@ package body Sem_Ch6 is ...@@ -236,7 +237,7 @@ package body Sem_Ch6 is
Analyze (P); Analyze (P);
-- A call of the form A.B (X) may be an Ada05 call, which is rewritten -- A call of the form A.B (X) may be an Ada05 call, which is rewritten
-- as B(A, X). If the rewriting is successful, the call has been -- as B (A, X). If the rewriting is successful, the call has been
-- analyzed and we just return. -- analyzed and we just return.
if Nkind (P) = N_Selected_Component if Nkind (P) = N_Selected_Component
...@@ -890,9 +891,16 @@ package body Sem_Ch6 is ...@@ -890,9 +891,16 @@ package body Sem_Ch6 is
Missing_Ret : Boolean; Missing_Ret : Boolean;
P_Ent : Entity_Id; P_Ent : Entity_Id;
procedure Check_Following_Pragma; procedure Check_Inline_Pragma (Spec : in out Node_Id);
-- If front-end inlining is enabled, look ahead to recognize a pragma -- Look ahead to recognize a pragma that may appear after the body.
-- that may appear after the body. -- If there is a previous spec, check that it appears in the same
-- declarative part. If the pragma is Inline_Always, perform inlining
-- unconditionally, otherwise only if Front_End_Inlining is requested.
-- If the body acts as a spec, and inlining is required, we create a
-- subprogram declaration for it, in order to attach the body to inline.
procedure Copy_Parameter_List (Plist : List_Id);
-- Comment required ???
procedure Verify_Overriding_Indicator; procedure Verify_Overriding_Indicator;
-- If there was a previous spec, the entity has been entered in the -- If there was a previous spec, the entity has been entered in the
...@@ -900,33 +908,115 @@ package body Sem_Ch6 is ...@@ -900,33 +908,115 @@ package body Sem_Ch6 is
-- indicator, check that it is consistent with the known status of the -- indicator, check that it is consistent with the known status of the
-- entity. -- entity.
---------------------------- -------------------------
-- Check_Following_Pragma -- -- Check_Inline_Pragma --
---------------------------- -------------------------
procedure Check_Following_Pragma is procedure Check_Inline_Pragma (Spec : in out Node_Id) is
Prag : Node_Id; Prag : Node_Id;
Plist : List_Id;
begin begin
if Front_End_Inlining if not Expander_Active then
and then Is_List_Member (N) return;
and then Present (Spec_Decl) end if;
and then List_Containing (N) = List_Containing (Spec_Decl)
if Is_List_Member (N)
and then Present (Next (N))
and then Nkind (Next (N)) = N_Pragma
then then
Prag := Next (N); Prag := Next (N);
if Present (Prag) if Nkind (Prag) = N_Pragma
and then Nkind (Prag) = N_Pragma and then
and then Get_Pragma_Id (Chars (Prag)) = Pragma_Inline (Get_Pragma_Id (Chars (Prag)) = Pragma_Inline_Always
or else
(Front_End_Inlining
and then Get_Pragma_Id (Chars (Prag)) = Pragma_Inline))
and then and then
Chars Chars
(Expression (First (Pragma_Argument_Associations (Prag)))) (Expression (First (Pragma_Argument_Associations (Prag))))
= Chars (Body_Id) = Chars (Body_Id)
then then
Analyze (Prag); Prag := Next (N);
else
Prag := Empty;
end if; end if;
else
Prag := Empty;
end if; end if;
end Check_Following_Pragma;
if Present (Prag) then
if Present (Spec_Id) then
if List_Containing (N) =
List_Containing (Unit_Declaration_Node (Spec_Id))
then
Analyze (Prag);
end if;
else
-- Create a subprogram declaration, to make treatment uniform.
declare
Subp : constant Entity_Id :=
Make_Defining_Identifier (Loc, Chars (Body_Id));
Decl : constant Node_Id :=
Make_Subprogram_Declaration (Loc,
Specification => New_Copy_Tree (Specification (N)));
begin
Set_Defining_Unit_Name (Specification (Decl), Subp);
if Present (First_Formal (Body_Id)) then
Plist := New_List;
Copy_Parameter_List (Plist);
Set_Parameter_Specifications
(Specification (Decl), Plist);
end if;
Insert_Before (N, Decl);
Analyze (Decl);
Analyze (Prag);
Set_Has_Pragma_Inline (Subp);
if Get_Pragma_Id (Chars (Prag)) = Pragma_Inline_Always then
Set_Is_Inlined (Subp);
Set_Next_Rep_Item (Prag, First_Rep_Item (Subp));
Set_First_Rep_Item (Subp, Prag);
end if;
Spec := Subp;
end;
end if;
end if;
end Check_Inline_Pragma;
-------------------------
-- Copy_Parameter_List --
-------------------------
procedure Copy_Parameter_List (Plist : List_Id) is
Formal : Entity_Id;
begin
Formal := First_Formal (Body_Id);
while Present (Formal) loop
Append
(Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Sloc (Formal),
Chars => Chars (Formal)),
In_Present => In_Present (Parent (Formal)),
Out_Present => Out_Present (Parent (Formal)),
Parameter_Type =>
New_Reference_To (Etype (Formal), Loc),
Expression =>
New_Copy_Tree (Expression (Parent (Formal)))),
Plist);
Next_Formal (Formal);
end loop;
end Copy_Parameter_List;
--------------------------------- ---------------------------------
-- Verify_Overriding_Indicator -- -- Verify_Overriding_Indicator --
...@@ -1071,6 +1161,8 @@ package body Sem_Ch6 is ...@@ -1071,6 +1161,8 @@ package body Sem_Ch6 is
end loop; end loop;
end if; end if;
Check_Inline_Pragma (Spec_Id);
-- Case of fully private operation in the body of the protected type. -- Case of fully private operation in the body of the protected type.
-- We must create a declaration for the subprogram, in order to attach -- We must create a declaration for the subprogram, in order to attach
-- the protected subprogram that will be used in internal calls. -- the protected subprogram that will be used in internal calls.
...@@ -1101,22 +1193,7 @@ package body Sem_Ch6 is ...@@ -1101,22 +1193,7 @@ package body Sem_Ch6 is
Plist := No_List; Plist := No_List;
end if; end if;
while Present (Formal) loop Copy_Parameter_List (Plist);
Append
(Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Sloc (Formal),
Chars => Chars (Formal)),
In_Present => In_Present (Parent (Formal)),
Out_Present => Out_Present (Parent (Formal)),
Parameter_Type =>
New_Reference_To (Etype (Formal), Loc),
Expression =>
New_Copy_Tree (Expression (Parent (Formal)))),
Plist);
Next_Formal (Formal);
end loop;
if Nkind (Body_Spec) = N_Procedure_Specification then if Nkind (Body_Spec) = N_Procedure_Specification then
New_Spec := New_Spec :=
...@@ -1337,14 +1414,11 @@ package body Sem_Ch6 is ...@@ -1337,14 +1414,11 @@ package body Sem_Ch6 is
elsif Present (Spec_Id) elsif Present (Spec_Id)
and then Expander_Active and then Expander_Active
and then
(Is_Always_Inlined (Spec_Id)
or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining))
then then
Check_Following_Pragma; Build_Body_To_Inline (N, Spec_Id);
if Is_Always_Inlined (Spec_Id)
or else (Has_Pragma_Inline (Spec_Id) and then Front_End_Inlining)
then
Build_Body_To_Inline (N, Spec_Id);
end if;
end if; end if;
-- Ada 2005 (AI-262): In library subprogram bodies, after the analysis -- Ada 2005 (AI-262): In library subprogram bodies, after the analysis
...@@ -2451,9 +2525,29 @@ package body Sem_Ch6 is ...@@ -2451,9 +2525,29 @@ package body Sem_Ch6 is
or else Is_Access_Constant (Etype (Old_Formal)) or else Is_Access_Constant (Etype (Old_Formal))
/= Is_Access_Constant (Etype (New_Formal))) /= Is_Access_Constant (Etype (New_Formal)))
then then
Conformance_Error -- It is allowed to omit the null-exclusion in case of
("type of & does not match!", New_Formal); -- stream attribute subprograms
return;
declare
TSS_Name : TSS_Name_Type;
begin
Get_Name_String (Chars (New_Id));
TSS_Name :=
TSS_Name_Type
(Name_Buffer
(Name_Len - TSS_Name'Length + 1 .. Name_Len));
if TSS_Name /= TSS_Stream_Read
and then TSS_Name /= TSS_Stream_Write
and then TSS_Name /= TSS_Stream_Input
and then TSS_Name /= TSS_Stream_Output
then
Conformance_Error
("type of & does not match!", New_Formal);
return;
end if;
end;
end if; end if;
-- Check default expressions for in parameters -- Check default expressions for in parameters
...@@ -4696,7 +4790,7 @@ package body Sem_Ch6 is ...@@ -4696,7 +4790,7 @@ package body Sem_Ch6 is
Decl : constant Node_Id := Unit_Declaration_Node (E); Decl : constant Node_Id := Unit_Declaration_Node (E);
begin begin
if Is_Package (Current_Scope) if Is_Package_Or_Generic_Package (Current_Scope)
and then In_Private_Part (Current_Scope) and then In_Private_Part (Current_Scope)
then then
Priv_Decls := Priv_Decls :=
...@@ -5014,7 +5108,7 @@ package body Sem_Ch6 is ...@@ -5014,7 +5108,7 @@ package body Sem_Ch6 is
-- the fact that the full view of a private extension -- the fact that the full view of a private extension
-- re-inherits. It has to be dealt with. -- re-inherits. It has to be dealt with.
if Is_Package (Current_Scope) if Is_Package_Or_Generic_Package (Current_Scope)
and then In_Private_Part (Current_Scope) and then In_Private_Part (Current_Scope)
then then
Check_Operation_From_Private_View (S, E); Check_Operation_From_Private_View (S, E);
...@@ -5423,9 +5517,12 @@ package body Sem_Ch6 is ...@@ -5423,9 +5517,12 @@ package body Sem_Ch6 is
and then Is_Access_Type (Formal_Type) and then Is_Access_Type (Formal_Type)
and then Null_Exclusion_Present (Param_Spec) and then Null_Exclusion_Present (Param_Spec)
then then
if Can_Never_Be_Null (Formal_Type) then if Can_Never_Be_Null (Formal_Type)
and then Comes_From_Source (Related_Nod)
then
Error_Msg_N Error_Msg_N
("(Ada 2005) already a null-excluding type", Related_Nod); ("null exclusion must apply to a type that does not "
& "exclude null ('R'M 3.10 (14)", Related_Nod);
end if; end if;
Formal_Type := Formal_Type :=
......
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