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

[multiple changes] 

2012-07-23  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch4.adb (Analyze_Selected_Component): When checking for
	potential ambiguities with class-wide operations on synchronized
	types, attach the copied node properly to the tree, to prevent
	errors during expansion.

2012-07-23  Yannick Moy  <moy@adacore.com>

	* sem_ch5.adb (Analyze_Loop_Statement): Make sure the loop body
	is analyzed in Alfa mode.

2012-07-23  Ed Schonberg  <schonberg@adacore.com>

	* sem_res.adb: Adjust previous change.

2012-07-23  Vincent Pucci  <pucci@adacore.com>

	* sem_ch9.adb (Allows_Lock_Free_Implementation): Flag
	Lock_Free_Given renames previous flag Complain. Description
	updated. Henceforth, catch every error messages issued by this
	routine when Lock_Free_Given is True.  Declaration restriction
	updated: No non-elementary parameter instead (even in parameter)
	New subprogram body restrictions implemented: No allocator,
	no address, import or export rep items, no delay statement,
	no goto statement, no quantified expression and no dereference
	of access value.

2012-07-23  Hristian Kirtchev  <kirtchev@adacore.com>

	* checks.adb (Determine_Range): Add local variable Btyp. Handle
	the case where the base type of an enumeration subtype is
	private. Replace all occurrences of Base_Type with Btyp.
	* exp_attr.adb (Attribute_Valid): Handle the case where the
	base type of an enumeration subtype is private. Replace all
	occurrences of Base_Type with Btyp.
	* sem_util.adb (Get_Enum_Lit_From_Pos): Add local variable
	Btyp. Handle the case where the base type of an enumeration
	subtype is private. Replace all occurrences of Base_Type with
	Btyp.

From-SVN: r189775
This commit is contained in:
Arnaud Charlet 2012-07-23 10:29:15 +02:00
parent 5087840447
commit d7a44b1442
9 changed files with 342 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
gcc/ada/ChangeLog
View File

@ -1,3 +1,44 @@
2012-07-23 Ed Schonberg <schonberg@adacore.com>
* sem_ch4.adb (Analyze_Selected_Component): When checking for
potential ambiguities with class-wide operations on synchronized
types, attach the copied node properly to the tree, to prevent
errors during expansion.
2012-07-23 Yannick Moy <moy@adacore.com>
* sem_ch5.adb (Analyze_Loop_Statement): Make sure the loop body
is analyzed in Alfa mode.
2012-07-23 Ed Schonberg <schonberg@adacore.com>
* sem_res.adb: Adjust previous change.
2012-07-23 Vincent Pucci <pucci@adacore.com>
* sem_ch9.adb (Allows_Lock_Free_Implementation): Flag
Lock_Free_Given renames previous flag Complain. Description
updated. Henceforth, catch every error messages issued by this
routine when Lock_Free_Given is True. Declaration restriction
updated: No non-elementary parameter instead (even in parameter)
New subprogram body restrictions implemented: No allocator,
no address, import or export rep items, no delay statement,
no goto statement, no quantified expression and no dereference
of access value.
2012-07-23 Hristian Kirtchev <kirtchev@adacore.com>
* checks.adb (Determine_Range): Add local variable Btyp. Handle
the case where the base type of an enumeration subtype is
private. Replace all occurrences of Base_Type with Btyp.
* exp_attr.adb (Attribute_Valid): Handle the case where the
base type of an enumeration subtype is private. Replace all
occurrences of Base_Type with Btyp.
* sem_util.adb (Get_Enum_Lit_From_Pos): Add local variable
Btyp. Handle the case where the base type of an enumeration
subtype is private. Replace all occurrences of Base_Type with
Btyp.
2012-07-23 Ed Schonberg <schonberg@adacore.com>
* par-ch6.adb (P_Mode): in Ada 2005, a mode indicator can apply

58
gcc/ada/checks.adb
View File

@ -3151,6 +3151,9 @@ package body Checks is
Cindex : Cache_Index;
-- Used to search cache
Btyp : Entity_Id;
-- Base type
function OK_Operands return Boolean;
-- Used for binary operators. Determines the ranges of the left and
-- right operands, and if they are both OK, returns True, and puts
@ -3267,6 +3270,15 @@ package body Checks is
Typ := Underlying_Type (Base_Type (Typ));
end if;
-- Retrieve the base type. Handle the case where the base type is a
-- private enumeration type.
Btyp := Base_Type (Typ);
if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
Btyp := Full_View (Btyp);
end if;
-- We use the actual bound unless it is dynamic, in which case use the
-- corresponding base type bound if possible. If we can't get a bound
-- then we figure we can't determine the range (a peculiar case, that
@ -3280,8 +3292,8 @@ package body Checks is
if Compile_Time_Known_Value (Bound) then
Lo := Expr_Value (Bound);
elsif Compile_Time_Known_Value (Type_Low_Bound (Base_Type (Typ))) then
Lo := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
elsif Compile_Time_Known_Value (Type_Low_Bound (Btyp)) then
Lo := Expr_Value (Type_Low_Bound (Btyp));
else
OK := False;
@ -3296,8 +3308,8 @@ package body Checks is
-- always be compile time known. Again, it is not clear that this
-- can ever be false, but no point in bombing.
if Compile_Time_Known_Value (Type_High_Bound (Base_Type (Typ))) then
Hbound := Expr_Value (Type_High_Bound (Base_Type (Typ)));
if Compile_Time_Known_Value (Type_High_Bound (Btyp)) then
Hbound := Expr_Value (Type_High_Bound (Btyp));
Hi := Hbound;
else
@ -4744,17 +4756,17 @@ package body Checks is
-- associated subtype.
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Not_In (Loc,
Left_Opnd =>
Convert_To (Base_Type (Etype (Sub)),
Duplicate_Subexpr_Move_Checks (Sub)),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Etype (A), Loc),
Attribute_Name => Name_Range)),
Reason => CE_Index_Check_Failed));
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Not_In (Loc,
Left_Opnd =>
Convert_To (Base_Type (Etype (Sub)),
Duplicate_Subexpr_Move_Checks (Sub)),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Etype (A), Loc),
Attribute_Name => Name_Range)),
Reason => CE_Index_Check_Failed));
end if;
-- General case
@ -4831,14 +4843,14 @@ package body Checks is
end if;
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Not_In (Loc,
Left_Opnd =>
Convert_To (Base_Type (Etype (Sub)),
Duplicate_Subexpr_Move_Checks (Sub)),
Right_Opnd => Range_N),
Reason => CE_Index_Check_Failed));
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Not_In (Loc,
Left_Opnd =>
Convert_To (Base_Type (Etype (Sub)),
Duplicate_Subexpr_Move_Checks (Sub)),
Right_Opnd => Range_N),
Reason => CE_Index_Check_Failed));
end if;
A_Idx := Next_Index (A_Idx);

12
gcc/ada/exp_attr.adb
View File

@ -5372,6 +5372,13 @@ package body Exp_Attr is
Validity_Checks_On := False;
-- Retrieve the base type. Handle the case where the base type is a
-- private enumeration type.
if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
Btyp := Full_View (Btyp);
end if;
-- Floating-point case. This case is handled by the Valid attribute
-- code in the floating-point attribute run-time library.
@ -5472,15 +5479,14 @@ package body Exp_Attr is
-- (X >= type(X)'First and then type(X)'Last <= X)
elsif Is_Enumeration_Type (Ptyp)
and then Present (Enum_Pos_To_Rep (Base_Type (Ptyp)))
and then Present (Enum_Pos_To_Rep (Btyp))
then
Tst :=
Make_Op_Ge (Loc,
Left_Opnd =>
Make_Function_Call (Loc,
Name =>
New_Reference_To
(TSS (Base_Type (Ptyp), TSS_Rep_To_Pos), Loc),
New_Reference_To (TSS (Btyp, TSS_Rep_To_Pos), Loc),
Parameter_Associations => New_List (
Pref,
New_Occurrence_Of (Standard_False, Loc))),

6
gcc/ada/exp_ch9.adb
View File

@ -3188,7 +3188,7 @@ package body Exp_Ch9 is
Rewrite (Stmt,
Make_Implicit_If_Statement (N,
Condition =>
Condition =>
Make_Function_Call (Loc,
Name =>
New_Reference_To (Try_Write, Loc),
@ -3379,9 +3379,9 @@ package body Exp_Ch9 is
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier =>
Defining_Identifier (Comp_Decl),
Subtype_Mark =>
Subtype_Mark =>
New_Occurrence_Of (Comp_Type, Loc),
Name =>
Name =>
New_Reference_To (Desired_Comp, Loc)));
-- Wrap any return or raise statements in Stmts in same the manner

18
gcc/ada/sem_ch4.adb
View File

@ -4222,13 +4222,21 @@ package body Sem_Ch4 is
-- Duplicate the call. This is required to avoid problems with
-- the tree transformations performed by Try_Object_Operation.
-- Set properly the parent of the copied call, because it is
-- about to be reanalyzed.
and then
Try_Object_Operation
(N => Sinfo.Name (New_Copy_Tree (Parent (N))),
CW_Test_Only => True)
then
return;
declare
Par : constant Node_Id := New_Copy_Tree (Parent (N));
begin
Set_Parent (Par, Parent (Parent (N)));
if Try_Object_Operation
(Sinfo.Name (Par), CW_Test_Only => True)
then
return;
end if;
end;
end if;
end if;

10
gcc/ada/sem_ch5.adb
View File

@ -2633,14 +2633,14 @@ package body Sem_Ch5 is
-- types the actual subtype of the components will only be determined
-- when the cursor declaration is analyzed.
-- If the expander is not active, then we want to analyze the loop body
-- now even in the Ada 2012 iterator case, since the rewriting will not
-- be done. Insert the loop variable in the current scope, if not done
-- when analysing the iteration scheme.
-- If the expander is not active, or in Alfa mode, then we want to
-- analyze the loop body now even in the Ada 2012 iterator case, since
-- the rewriting will not be done. Insert the loop variable in the
-- current scope, if not done when analysing the iteration scheme.
if No (Iter)
or else No (Iterator_Specification (Iter))
or else not Expander_Active
or else not Full_Expander_Active
then
if Present (Iter)
and then Present (Iterator_Specification (Iter))

275
gcc/ada/sem_ch9.adb
View File

@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
@ -68,24 +69,30 @@ package body Sem_Ch9 is
function Allows_Lock_Free_Implementation
(N : Node_Id;
Complain : Boolean := False) return Boolean;
Lock_Free_Given : Boolean := False) return Boolean;
-- This routine returns True iff N satisfies the following list of lock-
-- free restrictions for protected type declaration and protected body:
--
-- 1) Protected type declaration
-- May not contain entries
-- Component types must support atomic compare and exchange
-- Protected subprogram declarations may not have non-elementary
-- parameters.
--
-- 2) Protected Body
-- Each protected subprogram body within N must satisfy:
-- May reference only one protected component
-- May not reference non-constant entities outside the protected
-- subprogram scope.
-- May not reference non-elementary out parameters
-- May not contain loop statements or procedure calls
-- May not contain address representation items, allocators and
-- quantified expressions.
-- May not contain delay, goto, loop and procedure call
-- statements.
-- May not contain exported and imported entities
-- May not dereference access values
-- Function calls and attribute references must be static
--
-- If Complain is True, an error message is issued when False is returned
-- If Lock_Free_Given is True, an error message is issued when False is
-- returned.
procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions);
-- Given either a protected definition or a task definition in D, check
@ -115,22 +122,32 @@ package body Sem_Ch9 is
-------------------------------------
function Allows_Lock_Free_Implementation
(N : Node_Id;
Complain : Boolean := False) return Boolean
(N : Node_Id;
Lock_Free_Given : Boolean := False) return Boolean
is
Errors_Count : Nat;
-- Errors_Count is a count of errors detected by the compiler so far
-- when Lock_Free_Given is True.
begin
pragma Assert (Nkind_In (N,
N_Protected_Type_Declaration,
N_Protected_Body));
-- The lock-free implementation is currently enabled through a debug
-- flag. When Complain is True, an aspect Lock_Free forces the lock-free
-- implementation. In that case, the debug flag is not needed.
-- flag. When Lock_Free_Given is True, an aspect Lock_Free forces the
-- lock-free implementation. In that case, the debug flag is not needed.
if not Complain and then not Debug_Flag_9 then
if not Lock_Free_Given and then not Debug_Flag_9 then
return False;
end if;
-- Get the number of errors detected by the compiler so far
if Lock_Free_Given then
Errors_Count := Serious_Errors_Detected;
end if;
-- Protected type declaration case
if Nkind (N) = N_Protected_Type_Declaration then
@ -150,14 +167,14 @@ package body Sem_Ch9 is
-- restrictions.
if Nkind (Decl) = N_Entry_Declaration then
if Complain then
if Lock_Free_Given then
Error_Msg_N
("entry not allowed when Lock_Free given", Decl);
else
return False;
end if;
return False;
-- Non-elementary out parameters in protected procedure are not
-- Non-elementary parameters in protected procedure are not
-- allowed by the lock-free restrictions.
elsif Nkind (Decl) = N_Subprogram_Declaration
@ -176,18 +193,17 @@ package body Sem_Ch9 is
begin
Par := First (Par_Specs);
while Present (Par) loop
if Out_Present (Par)
and then not Is_Elementary_Type
(Etype (Parameter_Type (Par)))
if not Is_Elementary_Type
(Etype (Defining_Identifier (Par)))
then
if Complain then
if Lock_Free_Given then
Error_Msg_NE
("non-elementary out parameter& not allowed "
("non-elementary parameter& not allowed "
& "when Lock_Free given",
Par, Defining_Identifier (Par));
else
return False;
end if;
return False;
end if;
Next (Par);
@ -240,6 +256,10 @@ package body Sem_Ch9 is
Comp : Entity_Id := Empty;
-- Track the current component which the body references
Errors_Count : Nat;
-- Errors_Count is a count of errors detected by the compiler
-- so far when Lock_Free_Given is True.
function Check_Node (N : Node_Id) return Traverse_Result;
-- Check that node N meets the lock free restrictions
@ -248,6 +268,7 @@ package body Sem_Ch9 is
----------------
function Check_Node (N : Node_Id) return Traverse_Result is
Kind : constant Node_Kind := Nkind (N);
-- The following function belongs in sem_eval ???
@ -310,51 +331,123 @@ package body Sem_Ch9 is
begin
if Is_Procedure then
-- Attribute references must be static or denote a static
-- function.
-- Allocators restricted
if Nkind (N) = N_Attribute_Reference
if Kind = N_Allocator then
if Lock_Free_Given then
Error_Msg_N ("allocator not allowed", N);
return Skip;
end if;
return Abandon;
-- Aspects Address, Export and Import restricted
elsif Kind = N_Aspect_Specification then
declare
Asp_Name : constant Name_Id :=
Chars (Identifier (N));
Asp_Id : constant Aspect_Id :=
Get_Aspect_Id (Asp_Name);
begin
if Asp_Id = Aspect_Address
or else Asp_Id = Aspect_Export
or else Asp_Id = Aspect_Import
then
Error_Msg_Name_1 := Asp_Name;
if Lock_Free_Given then
Error_Msg_N ("aspect% not allowed", N);
return Skip;
end if;
return Abandon;
end if;
end;
-- Address attribute definition clause restricted
elsif Kind = N_Attribute_Definition_Clause
and then Get_Attribute_Id (Chars (N)) =
Attribute_Address
then
Error_Msg_Name_1 := Chars (N);
if Lock_Free_Given then
if From_Aspect_Specification (N) then
Error_Msg_N ("aspect% not allowed", N);
else
Error_Msg_N ("% clause not allowed", N);
end if;
return Skip;
end if;
return Abandon;
-- Non-static Attribute references that don't denote a
-- static function restricted.
elsif Kind = N_Attribute_Reference
and then not Is_Static_Expression (N)
and then not Is_Static_Function (N)
then
if Complain then
if Lock_Free_Given then
Error_Msg_N
("non-static attribute reference not allowed", N);
return Skip;
end if;
return Abandon;
-- Function calls must be static
-- Delay statements restricted
elsif Nkind (N) = N_Function_Call
elsif Kind in N_Delay_Statement then
if Lock_Free_Given then
Error_Msg_N ("delay not allowed", N);
return Skip;
end if;
return Abandon;
-- Explicit dereferences restricted (i.e. dereferences of
-- access values).
elsif Kind = N_Explicit_Dereference then
if Lock_Free_Given then
Error_Msg_N ("explicit dereference not allowed", N);
return Skip;
end if;
return Abandon;
-- Non-static function calls restricted
elsif Kind = N_Function_Call
and then not Is_Static_Expression (N)
then
if Complain then
if Lock_Free_Given then
Error_Msg_N ("non-static function call not allowed",
N);
return Skip;
end if;
return Abandon;
-- Loop statements and procedure calls are prohibited
-- Goto statements restricted
elsif Nkind (N) = N_Loop_Statement then
if Complain then
Error_Msg_N ("loop not allowed", N);
end if;
return Abandon;
elsif Nkind (N) = N_Procedure_Call_Statement then
if Complain then
Error_Msg_N ("procedure call not allowed", N);
elsif Kind = N_Goto_Statement then
if Lock_Free_Given then
Error_Msg_N ("goto statement not allowed", N);
return Skip;
end if;
return Abandon;
-- References
elsif Nkind (N) = N_Identifier
elsif Kind = N_Identifier
and then Present (Entity (N))
then
declare
@ -372,15 +465,75 @@ package body Sem_Ch9 is
and then not Scope_Within_Or_Same (Scope (Id),
Protected_Body_Subprogram (Sub_Id))
then
if Complain then
if Lock_Free_Given then
Error_Msg_NE
("reference to global variable& not " &
"allowed", N, Id);
return Skip;
end if;
return Abandon;
end if;
end;
-- Loop statements restricted
elsif Kind = N_Loop_Statement then
if Lock_Free_Given then
Error_Msg_N ("loop not allowed", N);
return Skip;
end if;
return Abandon;
-- Pragmas Export and Import restricted
elsif Kind = N_Pragma then
declare
Prag_Name : constant Name_Id := Pragma_Name (N);
Prag_Id : constant Pragma_Id :=
Get_Pragma_Id (Prag_Name);
begin
if Prag_Id = Pragma_Export
or else Prag_Id = Pragma_Import
then
Error_Msg_Name_1 := Prag_Name;
if Lock_Free_Given then
if From_Aspect_Specification (N) then
Error_Msg_N ("aspect% not allowed", N);
else
Error_Msg_N ("pragma% not allowed", N);
end if;
return Skip;
end if;
return Abandon;
end if;
end;
-- Procedure call statements restricted
elsif Kind = N_Procedure_Call_Statement then
if Lock_Free_Given then
Error_Msg_N ("procedure call not allowed", N);
return Skip;
end if;
return Abandon;
-- Quantified expression restricted
elsif Kind = N_Quantified_Expression then
if Lock_Free_Given then
Error_Msg_N ("quantified expression not allowed",
N);
return Skip;
end if;
return Abandon;
end if;
end if;
@ -388,7 +541,7 @@ package body Sem_Ch9 is
-- reference only one component of the protected type, plus
-- the type of the component must support atomic operation.
if Nkind (N) = N_Identifier
if Kind = N_Identifier
and then Present (Entity (N))
then
declare
@ -441,11 +594,12 @@ package body Sem_Ch9 is
when 8 | 16 | 32 | 64 =>
null;
when others =>
if Complain then
if Lock_Free_Given then
Error_Msg_NE
("type of& must support atomic " &
"operations",
N, Comp_Id);
return Skip;
end if;
return Abandon;
@ -458,10 +612,11 @@ package body Sem_Ch9 is
Comp := Comp_Id;
elsif Comp /= Comp_Id then
if Complain then
if Lock_Free_Given then
Error_Msg_N
("only one protected component allowed",
N);
return Skip;
end if;
return Abandon;
@ -479,7 +634,16 @@ package body Sem_Ch9 is
-- Start of processing for Satisfies_Lock_Free_Requirements
begin
if Check_All_Nodes (Sub_Body) = OK then
-- Get the number of errors detected by the compiler so far
if Lock_Free_Given then
Errors_Count := Serious_Errors_Detected;
end if;
if Check_All_Nodes (Sub_Body) = OK
and then (not Lock_Free_Given
or else Errors_Count = Serious_Errors_Detected)
then
-- Establish a relation between the subprogram body and the
-- unique protected component it references.
@ -503,12 +667,12 @@ package body Sem_Ch9 is
if Nkind (Decl) = N_Subprogram_Body
and then not Satisfies_Lock_Free_Requirements (Decl)
then
if Complain then
if Lock_Free_Given then
Error_Msg_N
("body not allowed when Lock_Free given", Decl);
("illegal body when Lock_Free given", Decl);
else
return False;
end if;
return False;
end if;
Next (Decl);
@ -516,6 +680,15 @@ package body Sem_Ch9 is
end Protected_Body_Case;
end if;
-- When Lock_Free is given, check if no error has been detected during
-- the process.
if Lock_Free_Given
and then Errors_Count /= Serious_Errors_Detected
then
return False;
end if;
return True;
end Allows_Lock_Free_Implementation;
@ -1611,7 +1784,7 @@ package body Sem_Ch9 is
-- otherwise Allows_Lock_Free_Implementation issues an error message.
if Uses_Lock_Free (Spec_Id) then
if not Allows_Lock_Free_Implementation (N, Complain => True) then
if not Allows_Lock_Free_Implementation (N, True) then
return;
end if;
@ -1886,7 +2059,7 @@ package body Sem_Ch9 is
end if;
end;
if not Allows_Lock_Free_Implementation (N, Complain => True) then
if not Allows_Lock_Free_Implementation (N, True) then
return;
end if;
end if;

7
gcc/ada/sem_res.adb
View File

@ -7071,7 +7071,8 @@ package body Sem_Res is
if Is_Overloaded (P) then
-- Use the context type to select the prefix that has the correct
-- designated type.
-- designated type. Keep the first match, which will be the inner-
-- most.
Get_First_Interp (P, I, It);
@ -7079,7 +7080,9 @@ package body Sem_Res is
if Is_Access_Type (It.Typ)
and then Covers (Typ, Designated_Type (It.Typ))
then
P_Typ := It.Typ;
if No (P_Typ) then
P_Typ := It.Typ;
end if;
-- Remove access types that do not match, but preserve access
-- to subprogram interpretations, in case a further dereference

9
gcc/ada/sem_util.adb
View File

@ -4500,7 +4500,8 @@ package body Sem_Util is
Pos : Uint;
Loc : Source_Ptr) return Node_Id
is
Lit : Node_Id;
Btyp : Entity_Id := Base_Type (T);
Lit : Node_Id;
begin
-- In the case where the literal is of type Character, Wide_Character
@ -4522,7 +4523,11 @@ package body Sem_Util is
--
else
Lit := First_Literal (Base_Type (T));
if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
Btyp := Full_View (Btyp);
end if;
Lit := First_Literal (Btyp);
for J in 1 .. UI_To_Int (Pos) loop
Next_Literal (Lit);
end loop;