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

exp_ch9.ads, [...] (Build_Protected_Entry, [...]): Generate debug info for declarations related to the handling of private data in...

Browse Source 
2008-04-08  Hristian Kirtchev  <kirtchev@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Robert Dewar  <dewar@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* exp_ch9.ads, exp_ch9.adb (Build_Protected_Entry,
	Build_Unprotected_Subprogram_Body): Generate debug info for
	declarations related to the handling of private data in task and
	protected types.
	(Debug_Private_Data_Declarations): New subprogram.
	(Install_Private_Data_Declarations): Remove all debug info flagging.
	This is now done by Debug_Private_Data_Declarations at the correct
	stage of expansion.
	(Build_Simple_Entry_Call): If the task name is a function call, expand
	the prefix into an object declaration, and make the surrounding block a
	task master.
	(Build_Master_Entity): An internal block is a master if it wraps a call.
	Code reformatting, update comments. Code clean up.
	(Make_Task_Create_Call): Use 'Unrestricted_Access instead of 'Address.
	(Replicate_Entry_Formals): If the formal is an access parameter or
	anonymous access to subprogram, copy the original tree to create new
	entities for the formals of the subprogram.
	(Expand_N_Task_Type_Declaration): Create a Relative_Deadline variable
	for tasks to store the value passed using pragma Relative_Deadline.
	(Make_Task_Create_Call): Add the Relative_Deadline argument to the
	run-time call to create a task.
	(Build_Wrapper_Spec): If the controlling argument of the interface
	operation is an access parameter with a non-null indicator, use the
	non-null indicator on the wrapper.

	* sem_ch9.adb (Analyze_Protected_Type): Only retrieve the full view when
	present, which it may not be in the case where the type entity is an
	incomplete view brought in by a limited with.
	(Analyze_Task_Type): Only retrieve the full view when present, which it
	may not be in the case where the type entity is an incomplete view
	brought in by a limited with.
	(Analyze_Protected_Definition): Set Is_Frozen on all itypes generated for
	private components of a protected type, to prevent the generation of
	freeze nodes for which there is no proper scope of elaboration.

	* exp_util.ads, exp_util.adb (Remove_Side_Effects): If the expression is
	a function call that returns a task, expand into a declaration to invoke
	the build_in_place machinery.
	(Find_Protection_Object): New routine.
	(Remove_Side_Effects): Also make a copy of the value
	for attributes whose result is of an elementary type.
	(Silly_Boolean_Array_Not_Test): New procedure
	(Silly_Boolean_Array_Xor_Test): New procedure
	(Is_Volatile_Reference): New function
	(Remove_Side_Effects): Use Is_Volatile_Reference
	(Possible_Bit_Aligned_Component): Handle slice case properly

	* exp_pakd.adb (Expand_Packed_Not): Move silly true/true or false/false
	case test to Exp_Util
	(Expand_Packed_Xor): Move silly true/true case test to Exp_Util

From-SVN: r134030
This commit is contained in:
Hristian Kirtchev 2008-04-08 08:50:51 +02:00 committed by Arnaud Charlet
parent dcfa065d7c
commit 65df5b7194
6 changed files with 1444 additions and 1264 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2078
gcc/ada/exp_ch9.adb
View File

File diff suppressed because it is too large Load Diff

151
gcc/ada/exp_ch9.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -25,7 +25,6 @@
-- Expand routines for chapter 9 constructs
with Namet; use Namet;
with Types; use Types;
package Exp_Ch9 is
@ -37,41 +36,6 @@ package Exp_Ch9 is
-- This type is used to distinguish the different protection modes of a
-- protected subprogram.
procedure Add_Discriminal_Declarations
(Decls : List_Id;
Typ : Entity_Id;
Name : Name_Id;
Loc : Source_Ptr);
-- This routine is used to add discriminal declarations to task and
-- protected operation bodies. The discriminants are available by normal
-- selection from the concurrent object (whose name is passed as the third
-- parameter). Discriminant references inside the body have already
-- been replaced by references to the corresponding discriminals. The
-- declarations constructed by this procedure hook the references up with
-- the objects:
--
-- discriminal_name : discr_type renames name.discriminant_name;
--
-- Obviously we could have expanded the discriminant references in the
-- first place to be the appropriate selection, but this turns out to
-- be hard to do because it would introduce difference in handling of
-- discriminant references depending on their location.
procedure Add_Private_Declarations
(Decls : List_Id;
Typ : Entity_Id;
Name : Name_Id;
Loc : Source_Ptr);
-- This routine is used to add private declarations to protected bodies.
-- These are analogous to the discriminal declarations added to tasks
-- and protected operations, and consist of a renaming of each private
-- object to a selection from the concurrent object passed as an extra
-- parameter to each such operation:
-- private_name : private_type renames name.private_name;
-- As with discriminals, private references inside the protected
-- subprogram bodies have already been replaced by references to the
-- corresponding privals.
procedure Build_Activation_Chain_Entity (N : Node_Id);
-- Given a declaration N of an object that is a task, or contains tasks
-- (other than allocators to tasks) this routine ensures that an activation
@ -113,12 +77,12 @@ package Exp_Ch9 is
-- declarative part.
function Build_Protected_Sub_Specification
(N : Node_Id;
Prottyp : Entity_Id;
Mode : Subprogram_Protection_Mode) return Node_Id;
-- Build specification for protected subprogram. This is called when
(N : Node_Id;
Prot_Typ : Entity_Id;
Mode : Subprogram_Protection_Mode) return Node_Id;
-- Build the specification for protected subprogram. This is called when
-- expanding a protected type, and also when expanding the declaration for
-- an Access_To_Protected_Subprogram type. In the latter case, Prottyp is
-- an Access_To_Protected_Subprogram type. In the latter case, Prot_Typ is
-- empty, and the first parameter of the signature of the protected op is
-- of type System.Address.
@ -242,10 +206,6 @@ package Exp_Ch9 is
-- now, within the context of the protected object, to resolve calls to
-- other protected functions.
procedure Expand_Entry_Body_Declarations (N : Node_Id);
-- Expand declarations required for the expansion of the
-- statements of the body.
procedure Expand_N_Abort_Statement (N : Node_Id);
procedure Expand_N_Accept_Statement (N : Node_Id);
procedure Expand_N_Asynchronous_Select (N : Node_Id);
@ -277,11 +237,10 @@ package Exp_Ch9 is
procedure Expand_Protected_Body_Declarations
(N : Node_Id;
Spec_Id : Entity_Id);
-- Expand declarations required for a protected body. See bodies of
-- both Expand_Protected_Body_Declarations and Expand_N_Protected_Body
-- for full details of the nature and use of these declarations.
-- The second argument is the entity for the corresponding
-- protected type declaration.
-- Expand declarations required for a protected body. See bodies of both
-- Expand_Protected_Body_Declarations and Expand_N_Protected_Body for full
-- details of the nature and use of these declarations. The second argument
-- is the entity for the corresponding protected type declaration.
function External_Subprogram (E : Entity_Id) return Entity_Id;
-- return the external version of a protected operation, which locks
@ -291,43 +250,79 @@ package Exp_Ch9 is
-- Given the declarations list for a protected body, find the
-- first protected operation body.
procedure Install_Private_Data_Declarations
(Loc : Source_Ptr;
Spec_Id : Entity_Id;
Conc_Typ : Entity_Id;
Body_Nod : Node_Id;
Decls : List_Id;
Barrier : Boolean := False;
Family : Boolean := False);
-- This routines generates several types, objects and object renamings used
-- in the handling of discriminants and private components of protected and
-- task types. It also generates the entry index for entry families. Formal
-- Spec_Id denotes an entry, entry family or a subprogram, Conc_Typ is the
-- concurrent type where Spec_Id resides, Body_Nod is the corresponding
-- body of Spec_Id, Decls are the declarations of the subprogram or entry.
-- Flag Barrier denotes whether the context is an entry barrier function.
-- Flag Family is used in conjunction with Barrier to denote a barrier for
-- an entry family.
--
-- The generated types, entities and renamings are:
--
-- * If flag Barrier is set or Spec_Id denotes a protected entry or an
-- entry family, generate:
--
-- type prot_typVP is access prot_typV;
-- _object : prot_typVP := prot_typV (_O);
--
-- where prot_typV is the corresponding record of a protected type and
-- _O is a formal parameter representing the concurrent object of either
-- the barrier function or the entry (family).
--
-- * If Conc_Typ is a protected type, create a renaming for the Protection
-- field _object:
--
-- conc_typR : protection_typ renames _object._object;
--
-- * If Conc_Typ has discriminants, create renamings of the form:
--
-- discr_nameD : discr_typ renames _object.discr_name;
-- or
-- discr_nameD : discr_typ renames _task.discr_name;
--
-- * If Conc_Typ denotes a protected type and has private components,
-- generate renamings of the form:
--
-- comp_name : comp_typ renames _object.comp_name;
--
-- * Finally, is flag Barrier and Family are set or Spec_Id denotes an
-- entry family, generate the entry index constant:
--
-- subtype Jnn is <Type of Index> range Low .. High;
-- J : constant Jnn :=
-- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First));
--
-- All the above declarations are inserted in the order shown to the front
-- of Decls.
function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id;
-- Given the entity of the record type created for a task type, build
-- the call to Create_Task
function Make_Initialize_Protection
(Protect_Rec : Entity_Id)
return List_Id;
(Protect_Rec : Entity_Id) return List_Id;
-- Given the entity of the record type created for a protected type, build
-- a list of statements needed for proper initialization of the object.
function Next_Protected_Operation (N : Node_Id) return Node_Id;
-- Given a protected operation node (a subprogram or entry body),
-- find the following node in the declarations list.
-- Given a protected operation node (a subprogram or entry body), find the
-- following node in the declarations list.
procedure Set_Discriminals (Dec : Node_Id);
-- Replace discriminals in a protected type for use by the
-- next protected operation on the type. Each operation needs a
-- new set of discriminals, since it needs a unique renaming of
-- the discriminant fields in the record used to implement the
-- protected type.
procedure Set_Privals
(Dec : Node_Id;
Op : Node_Id;
Loc : Source_Ptr;
After_Barrier : Boolean := False);
-- Associates a new set of privals (placeholders for later access to
-- private components of protected objects) with the private object
-- declarations of a protected object. These will be used to expand
-- the references to private objects in the next protected
-- subprogram or entry body to be expanded.
--
-- The flag After_Barrier indicates whether this is called after building
-- the barrier function for an entry body. This flag determines whether
-- the privals should have source names (which simplifies debugging) or
-- internally generated names. Entry barriers contain no debuggable code,
-- and there may be visibility conflicts between an entry index and a
-- a prival, so privals for barrier function have internal names.
-- Replace discriminals in a protected type for use by the next protected
-- operation on the type. Each operation needs a new set of discirminals,
-- since it needs a unique renaming of the discriminant fields in the
-- record used to implement the protected type.
end Exp_Ch9;

78
gcc/ada/exp_pakd.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -1092,7 +1092,7 @@ package body Exp_Pakd is
-- discriminants, so we treat it as a default/per-object expression.
Set_Parent (Len_Expr, Typ);
Analyze_Per_Use_Expression (Len_Expr, Standard_Long_Long_Integer);
Preanalyze_Spec_Expression (Len_Expr, Standard_Long_Long_Integer);
-- Use a modular type if possible. We can do this if we have
-- static bounds, and the length is small enough, and the length
@ -1774,47 +1774,11 @@ package body Exp_Pakd is
Ltyp := Etype (L);
Rtyp := Etype (R);
-- First an odd and silly test. We explicitly check for the XOR
-- case where the component type is True .. True, since this will
-- raise constraint error. A special check is required since CE
-- will not be required other wise (cf Expand_Packed_Not).
-- No such check is required for AND and OR, since for both these
-- cases False op False = False, and True op True = True.
-- Deeal with silly case of XOR where the subcomponent has a range
-- True .. True where an exception must be raised.
if Nkind (N) = N_Op_Xor then
declare
CT : constant Entity_Id := Component_Type (Rtyp);
BT : constant Entity_Id := Base_Type (CT);
begin
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_And (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (CT, Loc),
Attribute_Name => Name_First),
Right_Opnd =>
Convert_To (BT,
New_Occurrence_Of (Standard_True, Loc))),
Right_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (CT, Loc),
Attribute_Name => Name_Last),
Right_Opnd =>
Convert_To (BT,
New_Occurrence_Of (Standard_True, Loc)))),
Reason => CE_Range_Check_Failed));
end;
Silly_Boolean_Array_Xor_Test (N, Rtyp);
end if;
-- Now that that silliness is taken care of, get packed array type
@ -2186,37 +2150,11 @@ package body Exp_Pakd is
Convert_To_Actual_Subtype (Opnd);
Rtyp := Etype (Opnd);
-- First an odd and silly test. We explicitly check for the case
-- where the 'First of the component type is equal to the 'Last of
-- this component type, and if this is the case, we make sure that
-- constraint error is raised. The reason is that the NOT is bound
-- to cause CE in this case, and we will not otherwise catch it.
-- Deal with silly False..False and True..True subtype case
-- Believe it or not, this was reported as a bug. Note that nearly
-- always, the test will evaluate statically to False, so the code
-- will be statically removed, and no extra overhead caused.
Silly_Boolean_Array_Not_Test (N, Rtyp);
declare
CT : constant Entity_Id := Component_Type (Rtyp);
begin
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (CT, Loc),
Attribute_Name => Name_First),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (CT, Loc),
Attribute_Name => Name_Last)),
Reason => CE_Range_Check_Failed));
end;
-- Now that that silliness is taken care of, get packed array type
-- Now that the silliness is taken care of, get packed array type
Convert_To_PAT_Type (Opnd);
PAT := Etype (Opnd);

257
gcc/ada/exp_util.adb
View File

@ -336,7 +336,7 @@ package body Exp_Util is
-- component, whose prefix is the outer variable of the array type.
-- The n-dimensional array type has known indices Index, Index2...
-- Id_Ref is an indexed component form created by the enclosing init proc.
-- Its successive indices are Val1, Val2,.. which are the loop variables
-- Its successive indices are Val1, Val2, ... which are the loop variables
-- in the loops that call the individual task init proc on each component.
-- The generated function has the following structure:
@ -962,9 +962,16 @@ package body Exp_Util is
if Has_Entries (Typ)
or else Has_Interrupt_Handler (Typ)
or else (Has_Attach_Handler (Typ)
and then not Restricted_Profile)
or else (Ada_Version >= Ada_05
and then Present (Interface_List (Parent (Typ))))
and then not Restricted_Profile)
-- A protected type without entries that covers an interface and
-- overrides the abstract routines with protected procedures is
-- considered equivalent to a protected type with entries in the
-- context of dispatching select statements. It is sufficent to
-- check for the presence of an interface list in the declaration
-- node to recognize this case.
or else Present (Interface_List (Parent (Typ)))
then
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
@ -1814,6 +1821,34 @@ package body Exp_Util is
return Node (Prim);
end Find_Prim_Op;
----------------------------
-- Find_Protection_Object --
----------------------------
function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is
S : Entity_Id;
begin
S := Scop;
while Present (S) loop
if (Ekind (S) = E_Entry
or else Ekind (S) = E_Entry_Family
or else Ekind (S) = E_Function
or else Ekind (S) = E_Procedure)
and then Present (Protection_Object (S))
then
return Protection_Object (S);
end if;
S := Scope (S);
end loop;
-- If we do not find a Protection object in the scope chain, then
-- something has gone wrong, most likely the object was never created.
raise Program_Error;
end Find_Protection_Object;
----------------------
-- Force_Evaluation --
----------------------
@ -2292,13 +2327,14 @@ package body Exp_Util is
return;
end if;
-- Ignore insert of actions from inside default expression in the
-- special preliminary analyze mode. Any insertions at this point
-- have no relevance, since we are only doing the analyze to freeze
-- the types of any static expressions. See section "Handling of
-- Default Expressions" in the spec of package Sem for further details.
-- Ignore insert of actions from inside default expression (or other
-- similar "spec expression") in the special spec-expression analyze
-- mode. Any insertions at this point have no relevance, since we are
-- only doing the analyze to freeze the types of any static expressions.
-- See section "Handling of Default Expressions" in the spec of package
-- Sem for further details.
if In_Default_Expression then
if In_Spec_Expression then
return;
end if;
@ -3028,6 +3064,10 @@ package body Exp_Util is
Get_Name_String (Chars (E));
-- Most predefined primitives have internally generated names. Equality
-- must be treated differently; the predefined operation is recognized
-- as a homgeneous binary operator that returns Boolean.
if Name_Len > TSS_Name_Type'Last then
TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
.. Name_Len));
@ -3441,6 +3481,40 @@ package body Exp_Util is
and then Etype (Full_View (T)) /= T);
end Is_Untagged_Derivation;
---------------------------
-- Is_Volatile_Reference --
---------------------------
function Is_Volatile_Reference (N : Node_Id) return Boolean is
begin
if Nkind (N) in N_Has_Etype
and then Present (Etype (N))
and then Treat_As_Volatile (Etype (N))
then
return True;
elsif Is_Entity_Name (N) then
return Treat_As_Volatile (Entity (N));
elsif Nkind (N) = N_Slice then
return Is_Volatile_Reference (Prefix (N));
elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
if (Is_Entity_Name (Prefix (N))
and then Has_Volatile_Components (Entity (Prefix (N))))
or else (Present (Etype (Prefix (N)))
and then Has_Volatile_Components (Etype (Prefix (N))))
then
return True;
else
return Is_Volatile_Reference (Prefix (N));
end if;
else
return False;
end if;
end Is_Volatile_Reference;
--------------------
-- Kill_Dead_Code --
--------------------
@ -4257,9 +4331,15 @@ package body Exp_Util is
end if;
end;
-- If we have neither a record nor array component, it means that we
-- have fallen off the top testing prefixes recursively, and we now
-- have a stand alone object, where we don't have a problem.
-- For a slice, test the prefix, if that is possibly misaligned,
-- then for sure the slice is!
when N_Slice =>
return Possible_Bit_Aligned_Component (Prefix (N));
-- If we have none of the above, it means that we have fallen off the
-- top testing prefixes recursively, and we now have a stand alone
-- object, where we don't have a problem.
when others =>
return False;
@ -4375,7 +4455,7 @@ package body Exp_Util is
-- hand, if we do not consider them to be side effect free, then
-- we get some awkward expansions in -gnato mode, resulting in
-- code insertions at a point where we do not have a clear model
-- for performing the insertions. See 4908-002/comment for details.
-- for performing the insertions.
-- Special handling for entity names
@ -4399,14 +4479,13 @@ package body Exp_Util is
return False;
-- Variables are considered to be a side effect if Variable_Ref
-- is set or if we have a volatile variable and Name_Req is off.
-- is set or if we have a volatile reference and Name_Req is off.
-- If Name_Req is True then we can't help returning a name which
-- effectively allows multiple references in any case.
elsif Is_Variable (N) then
return not Variable_Ref
and then (not Treat_As_Volatile (Entity (N))
or else Name_Req);
and then (not Is_Volatile_Reference (N) or else Name_Req);
-- Any other entity (e.g. a subtype name) is definitely side
-- effect free.
@ -4631,17 +4710,16 @@ package body Exp_Util is
Scope_Suppress := (others => True);
-- If it is a scalar type and we need to capture the value, just make
-- a copy. Likewise for a function or operator call. And if we have a
-- volatile variable and Nam_Req is not set (see comments above for
-- Side_Effect_Free).
-- a copy. Likewise for a function call, an attribute reference or an
-- operator. And if we have a volatile reference and Name_Req is not
-- set (see comments above for Side_Effect_Free).
if Is_Elementary_Type (Exp_Type)
and then (Variable_Ref
or else Nkind (Exp) = N_Function_Call
or else Nkind (Exp) = N_Attribute_Reference
or else Nkind (Exp) in N_Op
or else (not Name_Req
and then Is_Entity_Name (Exp)
and then Treat_As_Volatile (Entity (Exp))))
or else (not Name_Req and then Is_Volatile_Reference (Exp)))
then
Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
Set_Etype (Def_Id, Exp_Type);
@ -4686,9 +4764,9 @@ package body Exp_Util is
-- If this is a type conversion, leave the type conversion and remove
-- the side effects in the expression. This is important in several
-- circumstances: for change of representations, and also when this
-- is a view conversion to a smaller object, where gigi can end up
-- creating its own temporary of the wrong size.
-- circumstances: for change of representations, and also when this is
-- a view conversion to a smaller object, where gigi can end up creating
-- its own temporary of the wrong size.
elsif Nkind (Exp) = N_Type_Conversion then
Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
@ -4732,14 +4810,12 @@ package body Exp_Util is
end if;
-- For expressions that denote objects, we can use a renaming scheme.
-- We skip using this if we have a volatile variable and we do not
-- have Nam_Req set true (see comments above for Side_Effect_Free).
-- We skip using this if we have a volatile reference and we do not
-- have Name_Req set true (see comments above for Side_Effect_Free).
elsif Is_Object_Reference (Exp)
and then Nkind (Exp) /= N_Function_Call
and then (Name_Req
or else not Is_Entity_Name (Exp)
or else not Treat_As_Volatile (Entity (Exp)))
and then (Name_Req or else not Is_Volatile_Reference (Exp))
then
Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
@ -4778,7 +4854,7 @@ package body Exp_Util is
-- If this is a packed reference, or a selected component with a
-- non-standard representation, a reference to the temporary will
-- be replaced by a copy of the original expression (see
-- exp_ch2.Expand_Renaming). Otherwise the temporary must be
-- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be
-- elaborated by gigi, and is of course not to be replaced in-line
-- by the expression it renames, which would defeat the purpose of
-- removing the side-effect.
@ -4795,6 +4871,36 @@ package body Exp_Util is
-- Otherwise we generate a reference to the value
else
-- Special processing for function calls that return a task. We need
-- to build a declaration that will enable build-in-place expansion
-- of the call.
-- This is relevant only in Ada 2005 mode. In Ada 95 programs we have
-- to accommodate functions returning limited objects by reference.
if Nkind (Exp) = N_Function_Call
and then Is_Task_Type (Etype (Exp))
and then Ada_Version >= Ada_05
then
declare
Obj : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('F'));
Decl : Node_Id;
begin
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Obj,
Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
Expression => Relocate_Node (Exp));
Insert_Action (Exp, Decl);
Set_Etype (Obj, Exp_Type);
Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
return;
end;
end if;
Ref_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Ptr_Typ_Decl :=
@ -5202,9 +5308,9 @@ package body Exp_Util is
Analyze (Asn);
-- Kill current value indication. This is necessary because
-- the tests of this flag are inserted out of sequence and must
-- not pick up bogus indications of the wrong constant value.
-- Kill current value indication. This is necessary because the
-- tests of this flag are inserted out of sequence and must not
-- pick up bogus indications of the wrong constant value.
Set_Current_Value (Ent, Empty);
end if;
@ -5237,6 +5343,87 @@ package body Exp_Util is
end if;
end Set_Renamed_Subprogram;
----------------------------------
-- Silly_Boolean_Array_Not_Test --
----------------------------------
-- This procedure implements an odd and silly test. We explicitly check
-- for the case where the 'First of the component type is equal to the
-- 'Last of this component type, and if this is the case, we make sure
-- that constraint error is raised. The reason is that the NOT is bound
-- to cause CE in this case, and we will not otherwise catch it.
-- Believe it or not, this was reported as a bug. Note that nearly
-- always, the test will evaluate statically to False, so the code will
-- be statically removed, and no extra overhead caused.
procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
CT : constant Entity_Id := Component_Type (T);
begin
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (CT, Loc),
Attribute_Name => Name_First),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (CT, Loc),
Attribute_Name => Name_Last)),
Reason => CE_Range_Check_Failed));
end Silly_Boolean_Array_Not_Test;
----------------------------------
-- Silly_Boolean_Array_Xor_Test --
----------------------------------
-- This procedure implements an odd and silly test. We explicitly check
-- for the XOR case where the component type is True .. True, since this
-- will raise constraint error. A special check is required since CE
-- will not be required otherwise (cf Expand_Packed_Not).
-- No such check is required for AND and OR, since for both these cases
-- False op False = False, and True op True = True.
procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
CT : constant Entity_Id := Component_Type (T);
BT : constant Entity_Id := Base_Type (CT);
begin
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_And (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (CT, Loc),
Attribute_Name => Name_First),
Right_Opnd =>
Convert_To (BT,
New_Occurrence_Of (Standard_True, Loc))),
Right_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (CT, Loc),
Attribute_Name => Name_Last),
Right_Opnd =>
Convert_To (BT,
New_Occurrence_Of (Standard_True, Loc)))),
Reason => CE_Range_Check_Failed));
end Silly_Boolean_Array_Xor_Test;
--------------------------
-- Target_Has_Fixed_Ops --
--------------------------

26
gcc/ada/exp_util.ads
View File

@ -372,6 +372,13 @@ package Exp_Util is
-- operation which is not directly visible. If T is a class wide type,
-- then the reference is to an operation of the corresponding root type.
function Find_Protection_Object (Scop : Entity_Id) return Entity_Id;
-- Traverse the scope stack starting from Scop and look for an entry,
-- entry family, or a subprogram that has a Protection_Object and return
-- it. Raises Program_Error if no such entity is found since the context
-- in which this routine is invoked should always have a protection
-- object.
procedure Force_Evaluation
(Exp : Node_Id;
Name_Req : Boolean := False);
@ -491,6 +498,13 @@ package Exp_Util is
-- Returns true if type T is not tagged and is a derived type,
-- or is a private type whose completion is such a type.
function Is_Volatile_Reference (N : Node_Id) return Boolean;
-- Checks if the node N represents a volatile reference, which can be
-- either a direct reference to a variable treated as volatile, or an
-- indexed/selected component where the prefix is treated as volatile,
-- or has Volatile_Components set. A slice of a volatile variable is
-- also volatile.
procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False);
-- N represents a node for a section of code that is known to be dead. Any
-- exception handler references and warning messages relating to this code
@ -613,6 +627,18 @@ package Exp_Util is
-- renamed subprogram. The node is rewritten to be an identifier that
-- refers directly to the renamed subprogram, given by entity E.
procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id);
-- N is the node for a boolean array NOT operation, and T is the type of
-- the array. This routine deals with the silly case where the subtype of
-- the boolean array is False..False or True..True, where it is required
-- that a Constraint_Error exception be raised (RM 4.5.6(6)).
procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id);
-- N is the node for a boolean array XOR operation, and T is the type of
-- the array. This routine deals with the silly case where the subtype of
-- the boolean array is True..True, where a raise of a Constraint_Error
-- exception is required (RM 4.5.6(6)).
function Target_Has_Fixed_Ops
(Left_Typ : Entity_Id;
Right_Typ : Entity_Id;

118
gcc/ada/sem_ch9.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -570,9 +570,9 @@ package body Sem_Ch9 is
-- expression is only evaluated if the guard is open.
if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then
Pre_Analyze_And_Resolve (Expr, Standard_Duration);
Preanalyze_And_Resolve (Expr, Standard_Duration);
else
Pre_Analyze_And_Resolve (Expr);
Preanalyze_And_Resolve (Expr);
end if;
Typ := First_Subtype (Etype (Expr));
@ -646,8 +646,8 @@ package body Sem_Ch9 is
Stats : constant Node_Id := Handled_Statement_Sequence (N);
Formals : constant Node_Id := Entry_Body_Formal_Part (N);
P_Type : constant Entity_Id := Current_Scope;
Entry_Name : Entity_Id;
E : Entity_Id;
Entry_Name : Entity_Id;
begin
Tasking_Used := True;
@ -765,7 +765,6 @@ package body Sem_Ch9 is
Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name);
Push_Scope (Entry_Name);
Exp_Ch9.Expand_Entry_Body_Declarations (N);
Install_Declarations (Entry_Name);
Set_Actual_Subtypes (N, Current_Scope);
@ -783,6 +782,17 @@ package body Sem_Ch9 is
Set_Entry_Parameters_Type
(Id, Entry_Parameters_Type (Entry_Name));
-- Add a declaration for the Protection object, renaming declarations
-- for the discriminals and privals and finally a declaration for the
-- entry family index (if applicable).
if Expander_Active
and then Is_Protected_Type (P_Type)
then
Install_Private_Data_Declarations
(Sloc (N), Entry_Name, P_Type, N, Decls);
end if;
if Present (Decls) then
Analyze_Declarations (Decls);
end if;
@ -926,40 +936,40 @@ package body Sem_Ch9 is
-------------------------------
procedure Analyze_Entry_Declaration (N : Node_Id) is
Formals : constant List_Id := Parameter_Specifications (N);
Id : constant Entity_Id := Defining_Identifier (N);
D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N);
Def_Id : constant Entity_Id := Defining_Identifier (N);
Formals : constant List_Id := Parameter_Specifications (N);
begin
Generate_Definition (Id);
Generate_Definition (Def_Id);
Tasking_Used := True;
if No (D_Sdef) then
Set_Ekind (Id, E_Entry);
Set_Ekind (Def_Id, E_Entry);
else
Enter_Name (Id);
Set_Ekind (Id, E_Entry_Family);
Enter_Name (Def_Id);
Set_Ekind (Def_Id, E_Entry_Family);
Analyze (D_Sdef);
Make_Index (D_Sdef, N, Id);
Make_Index (D_Sdef, N, Def_Id);
end if;
Set_Etype (Id, Standard_Void_Type);
Set_Convention (Id, Convention_Entry);
Set_Accept_Address (Id, New_Elmt_List);
Set_Etype (Def_Id, Standard_Void_Type);
Set_Convention (Def_Id, Convention_Entry);
Set_Accept_Address (Def_Id, New_Elmt_List);
if Present (Formals) then
Set_Scope (Id, Current_Scope);
Push_Scope (Id);
Set_Scope (Def_Id, Current_Scope);
Push_Scope (Def_Id);
Process_Formals (Formals, N);
Create_Extra_Formals (Id);
Create_Extra_Formals (Def_Id);
End_Scope;
end if;
if Ekind (Id) = E_Entry then
New_Overloaded_Entity (Id);
if Ekind (Def_Id) = E_Entry then
New_Overloaded_Entity (Def_Id);
end if;
Generate_Reference_To_Formals (Id);
Generate_Reference_To_Formals (Def_Id);
end Analyze_Entry_Declaration;
---------------------------------------
@ -1061,7 +1071,7 @@ package body Sem_Ch9 is
Set_Has_Completion (Spec_Id);
Install_Declarations (Spec_Id);
Exp_Ch9.Expand_Protected_Body_Declarations (N, Spec_Id);
Expand_Protected_Body_Declarations (N, Spec_Id);
Last_E := Last_Entity (Spec_Id);
@ -1093,6 +1103,55 @@ package body Sem_Ch9 is
E : Entity_Id;
L : Entity_Id;
procedure Undelay_Itypes (T : Entity_Id);
-- Itypes created for the private components of a protected type
-- do not receive freeze nodes, because there is no scope in which
-- they can be elaborated, and they can depend on discriminants of
-- the enclosed protected type. Given that the components can be
-- composite types with inner components, we traverse recursively
-- the private components of the protected type, and indicate that
-- all itypes within are frozen. This ensures that no freeze nodes
-- will be generated for them.
--
-- On the other hand, components of the correesponding record are
-- frozen (or receive itype references) as for other records.
--------------------
-- Undelay_Itypes --
--------------------
procedure Undelay_Itypes (T : Entity_Id) is
Comp : Entity_Id;
begin
if Is_Protected_Type (T) then
Comp := First_Private_Entity (T);
elsif Is_Record_Type (T) then
Comp := First_Entity (T);
else
return;
end if;
while Present (Comp) loop
if Is_Type (Comp)
and then Is_Itype (Comp)
then
Set_Has_Delayed_Freeze (Comp, False);
Set_Is_Frozen (Comp);
if Is_Record_Type (Comp)
or else Is_Protected_Type (Comp)
then
Undelay_Itypes (Comp);
end if;
end if;
Next_Entity (Comp);
end loop;
end Undelay_Itypes;
-- Start of processing for Analyze_Protected_Definition
begin
Tasking_Used := True;
Analyze_Declarations (Visible_Declarations (N));
@ -1127,6 +1186,8 @@ package body Sem_Ch9 is
Next_Entity (E);
end loop;
Undelay_Itypes (Current_Scope);
Check_Max_Entries (N, Max_Protected_Entries);
Process_End_Label (N, 'e', Current_Scope);
end Analyze_Protected_Definition;
@ -1151,7 +1212,10 @@ package body Sem_Ch9 is
T := Find_Type_Name (N);
if Ekind (T) = E_Incomplete_Type then
-- In the case of an incomplete type, use the full view, unless it's not
-- present (as can occur for an incomplete view from a limited with).
if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then
T := Full_View (T);
Set_Completion_Referenced (T);
end if;
@ -1776,6 +1840,7 @@ package body Sem_Ch9 is
procedure Analyze_Task_Body (N : Node_Id) is
Body_Id : constant Entity_Id := Defining_Identifier (N);
Decls : constant List_Id := Declarations (N);
HSS : constant Node_Id := Handled_Statement_Sequence (N);
Last_E : Entity_Id;
@ -1842,7 +1907,7 @@ package body Sem_Ch9 is
Install_Declarations (Spec_Id);
Last_E := Last_Entity (Spec_Id);
Analyze_Declarations (Declarations (N));
Analyze_Declarations (Decls);
-- For visibility purposes, all entities in the body are private. Set
-- First_Private_Entity accordingly, if there was no private part in the
@ -1946,7 +2011,10 @@ package body Sem_Ch9 is
T := Find_Type_Name (N);
Generate_Definition (T);
if Ekind (T) = E_Incomplete_Type then
-- In the case of an incomplete type, use the full view, unless it's not
-- present (as can occur for an incomplete view from a limited with).
if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then
T := Full_View (T);
Set_Completion_Referenced (T);
end if;