[multiple changes]
2011-12-20 Hristian Kirtchev <kirtchev@adacore.com> * exp_ch11.adb (Find_Local_Handler): Guard the search over individual exception choices in case the list of handlers contains other (possibly illegal) constructs. 2011-12-20 Gary Dismukes <dismukes@adacore.com> * sem_ch8.adb (Find_Type): Test taggedness of the Available_Type when checking for an illegal use of an incomplete type, when the incomplete view is a limited view of a type. Remove redundant Is_Tagged test. 2011-12-20 Hristian Kirtchev <kirtchev@adacore.com> * exp_util.adb: Add with and use clause for Aspects. (Is_Finalizable_Transient): Objects which denote Ada containers in the context of iterators are not considered transients. Such object must live for as long as the loop is around. (Is_Iterated_Container): New routine. 2011-12-20 Hristian Kirtchev <kirtchev@adacore.com> * exp_imgv.adb (Expand_Width_Attribute): Add a type conversion from the enumeration subtype to its base subtype. From-SVN: r182539
This commit is contained in:
parent
b26f70a095
commit
2f7b74678b
|
@ -1,3 +1,29 @@
|
||||||
|
2011-12-20 Hristian Kirtchev <kirtchev@adacore.com>
|
||||||
|
|
||||||
|
* exp_ch11.adb (Find_Local_Handler): Guard the
|
||||||
|
search over individual exception choices in case the list of
|
||||||
|
handlers contains other (possibly illegal) constructs.
|
||||||
|
|
||||||
|
2011-12-20 Gary Dismukes <dismukes@adacore.com>
|
||||||
|
|
||||||
|
* sem_ch8.adb (Find_Type): Test taggedness
|
||||||
|
of the Available_Type when checking for an illegal use of an
|
||||||
|
incomplete type, when the incomplete view is a limited view of
|
||||||
|
a type. Remove redundant Is_Tagged test.
|
||||||
|
|
||||||
|
2011-12-20 Hristian Kirtchev <kirtchev@adacore.com>
|
||||||
|
|
||||||
|
* exp_util.adb: Add with and use clause for Aspects.
|
||||||
|
(Is_Finalizable_Transient): Objects which denote Ada containers
|
||||||
|
in the context of iterators are not considered transients. Such
|
||||||
|
object must live for as long as the loop is around.
|
||||||
|
(Is_Iterated_Container): New routine.
|
||||||
|
|
||||||
|
2011-12-20 Hristian Kirtchev <kirtchev@adacore.com>
|
||||||
|
|
||||||
|
* exp_imgv.adb (Expand_Width_Attribute): Add a
|
||||||
|
type conversion from the enumeration subtype to its base subtype.
|
||||||
|
|
||||||
2011-12-20 Hristian Kirtchev <kirtchev@adacore.com>
|
2011-12-20 Hristian Kirtchev <kirtchev@adacore.com>
|
||||||
|
|
||||||
* sem_ch4.adb (Operator_Check): Update the call to
|
* sem_ch4.adb (Operator_Check): Update the call to
|
||||||
|
|
|
@ -1913,49 +1913,57 @@ package body Exp_Ch11 is
|
||||||
H := First (Exception_Handlers (P));
|
H := First (Exception_Handlers (P));
|
||||||
while Present (H) loop
|
while Present (H) loop
|
||||||
|
|
||||||
-- Loop through choices in one handler
|
-- Guard against other constructs appearing in the list of
|
||||||
|
-- exception handlers.
|
||||||
|
|
||||||
C := First (Exception_Choices (H));
|
if Nkind (H) = N_Exception_Handler then
|
||||||
while Present (C) loop
|
|
||||||
|
|
||||||
-- Deal with others case
|
-- Loop through choices in one handler
|
||||||
|
|
||||||
if Nkind (C) = N_Others_Choice then
|
C := First (Exception_Choices (H));
|
||||||
|
while Present (C) loop
|
||||||
|
|
||||||
-- Matching others handler, but we need to ensure
|
-- Deal with others case
|
||||||
-- there is no choice parameter. If there is, then we
|
|
||||||
-- don't have a local handler after all (since we do
|
|
||||||
-- not allow choice parameters for local handlers).
|
|
||||||
|
|
||||||
if No (Choice_Parameter (H)) then
|
if Nkind (C) = N_Others_Choice then
|
||||||
return H;
|
|
||||||
else
|
|
||||||
return Empty;
|
|
||||||
end if;
|
|
||||||
|
|
||||||
-- If not others must be entity name
|
-- Matching others handler, but we need to ensure
|
||||||
|
-- there is no choice parameter. If there is, then
|
||||||
|
-- we don't have a local handler after all (since
|
||||||
|
-- we do not allow choice parameters for local
|
||||||
|
-- handlers).
|
||||||
|
|
||||||
elsif Nkind (C) /= N_Others_Choice then
|
|
||||||
pragma Assert (Is_Entity_Name (C));
|
|
||||||
pragma Assert (Present (Entity (C)));
|
|
||||||
|
|
||||||
-- Get exception being handled, dealing with renaming
|
|
||||||
|
|
||||||
EHandle := Get_Renamed_Entity (Entity (C));
|
|
||||||
|
|
||||||
-- If match, then check choice parameter
|
|
||||||
|
|
||||||
if ERaise = EHandle then
|
|
||||||
if No (Choice_Parameter (H)) then
|
if No (Choice_Parameter (H)) then
|
||||||
return H;
|
return H;
|
||||||
else
|
else
|
||||||
return Empty;
|
return Empty;
|
||||||
end if;
|
end if;
|
||||||
end if;
|
|
||||||
end if;
|
|
||||||
|
|
||||||
Next (C);
|
-- If not others must be entity name
|
||||||
end loop;
|
|
||||||
|
elsif Nkind (C) /= N_Others_Choice then
|
||||||
|
pragma Assert (Is_Entity_Name (C));
|
||||||
|
pragma Assert (Present (Entity (C)));
|
||||||
|
|
||||||
|
-- Get exception being handled, dealing with
|
||||||
|
-- renaming.
|
||||||
|
|
||||||
|
EHandle := Get_Renamed_Entity (Entity (C));
|
||||||
|
|
||||||
|
-- If match, then check choice parameter
|
||||||
|
|
||||||
|
if ERaise = EHandle then
|
||||||
|
if No (Choice_Parameter (H)) then
|
||||||
|
return H;
|
||||||
|
else
|
||||||
|
return Empty;
|
||||||
|
end if;
|
||||||
|
end if;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Next (C);
|
||||||
|
end loop;
|
||||||
|
end if;
|
||||||
|
|
||||||
Next (H);
|
Next (H);
|
||||||
end loop;
|
end loop;
|
||||||
|
|
|
@ -1177,7 +1177,7 @@ package body Exp_Imgv is
|
||||||
-- ...
|
-- ...
|
||||||
-- else n)))...
|
-- else n)))...
|
||||||
|
|
||||||
-- where n is equal to Rtyp'Pos (Rtyp'Last) + 1
|
-- where n is equal to Rtyp'Pos (Ptyp'Last) + 1
|
||||||
|
|
||||||
-- Note: The above processing is in accordance with the intent of
|
-- Note: The above processing is in accordance with the intent of
|
||||||
-- the RM, which is that Width should be related to the impl-defined
|
-- the RM, which is that Width should be related to the impl-defined
|
||||||
|
@ -1206,12 +1206,13 @@ package body Exp_Imgv is
|
||||||
New_Occurrence_Of (Standard_Integer, Loc),
|
New_Occurrence_Of (Standard_Integer, Loc),
|
||||||
Expression =>
|
Expression =>
|
||||||
Make_Attribute_Reference (Loc,
|
Make_Attribute_Reference (Loc,
|
||||||
Prefix => New_Occurrence_Of (Rtyp, Loc),
|
Prefix => New_Occurrence_Of (Rtyp, Loc),
|
||||||
Attribute_Name => Name_Pos,
|
Attribute_Name => Name_Pos,
|
||||||
Expressions => New_List (
|
Expressions => New_List (
|
||||||
Make_Attribute_Reference (Loc,
|
Convert_To (Rtyp,
|
||||||
Prefix => New_Occurrence_Of (Ptyp, Loc),
|
Make_Attribute_Reference (Loc,
|
||||||
Attribute_Name => Name_Last)))));
|
Prefix => New_Occurrence_Of (Ptyp, Loc),
|
||||||
|
Attribute_Name => Name_Last))))));
|
||||||
|
|
||||||
-- OK, now we need to build the conditional expression. First
|
-- OK, now we need to build the conditional expression. First
|
||||||
-- get the value of M, the largest possible value needed.
|
-- get the value of M, the largest possible value needed.
|
||||||
|
|
|
@ -23,6 +23,7 @@
|
||||||
-- --
|
-- --
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
with Aspects; use Aspects;
|
||||||
with Atree; use Atree;
|
with Atree; use Atree;
|
||||||
with Casing; use Casing;
|
with Casing; use Casing;
|
||||||
with Checks; use Checks;
|
with Checks; use Checks;
|
||||||
|
@ -3966,6 +3967,13 @@ package body Exp_Util is
|
||||||
function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
|
function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
|
||||||
-- Determine whether transient object Trans_Id is allocated on the heap
|
-- Determine whether transient object Trans_Id is allocated on the heap
|
||||||
|
|
||||||
|
function Is_Iterated_Container
|
||||||
|
(Trans_Id : Entity_Id;
|
||||||
|
First_Stmt : Node_Id) return Boolean;
|
||||||
|
-- Determine whether transient object Trans_Id denotes a container which
|
||||||
|
-- is in the process of being iterated in the statement list starting
|
||||||
|
-- from First_Stmt.
|
||||||
|
|
||||||
---------------------------
|
---------------------------
|
||||||
-- Initialized_By_Access --
|
-- Initialized_By_Access --
|
||||||
---------------------------
|
---------------------------
|
||||||
|
@ -4180,6 +4188,90 @@ package body Exp_Util is
|
||||||
and then Nkind (Expr) = N_Allocator;
|
and then Nkind (Expr) = N_Allocator;
|
||||||
end Is_Allocated;
|
end Is_Allocated;
|
||||||
|
|
||||||
|
---------------------------
|
||||||
|
-- Is_Iterated_Container --
|
||||||
|
---------------------------
|
||||||
|
|
||||||
|
function Is_Iterated_Container
|
||||||
|
(Trans_Id : Entity_Id;
|
||||||
|
First_Stmt : Node_Id) return Boolean
|
||||||
|
is
|
||||||
|
Aspect : Node_Id;
|
||||||
|
Call : Node_Id;
|
||||||
|
Iter : Entity_Id;
|
||||||
|
Param : Node_Id;
|
||||||
|
Stmt : Node_Id;
|
||||||
|
Typ : Entity_Id;
|
||||||
|
|
||||||
|
begin
|
||||||
|
-- It is not possible to iterate over containers in non-Ada 2012 code
|
||||||
|
|
||||||
|
if Ada_Version < Ada_2012 then
|
||||||
|
return False;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Typ := Etype (Trans_Id);
|
||||||
|
|
||||||
|
-- Handle access type created for secondary stack use
|
||||||
|
|
||||||
|
if Is_Access_Type (Typ) then
|
||||||
|
Typ := Designated_Type (Typ);
|
||||||
|
end if;
|
||||||
|
|
||||||
|
-- Look for aspect Default_Iterator
|
||||||
|
|
||||||
|
if Has_Aspects (Parent (Typ)) then
|
||||||
|
Aspect := Find_Aspect (Typ, Aspect_Default_Iterator);
|
||||||
|
|
||||||
|
if Present (Aspect) then
|
||||||
|
Iter := Entity (Aspect);
|
||||||
|
|
||||||
|
-- Examine the statements following the container object and
|
||||||
|
-- look for a call to the default iterate routine where the
|
||||||
|
-- first parameter is the transient. Such a call appears as:
|
||||||
|
|
||||||
|
-- It : Access_To_CW_Iterator :=
|
||||||
|
-- Iterate (Tran_Id.all, ...)'reference;
|
||||||
|
|
||||||
|
Stmt := First_Stmt;
|
||||||
|
while Present (Stmt) loop
|
||||||
|
|
||||||
|
-- Detect an object declaration which is initialized by a
|
||||||
|
-- secondary stack function call.
|
||||||
|
|
||||||
|
if Nkind (Stmt) = N_Object_Declaration
|
||||||
|
and then Present (Expression (Stmt))
|
||||||
|
and then Nkind (Expression (Stmt)) = N_Reference
|
||||||
|
and then Nkind (Prefix (Expression (Stmt))) =
|
||||||
|
N_Function_Call
|
||||||
|
then
|
||||||
|
Call := Prefix (Expression (Stmt));
|
||||||
|
|
||||||
|
-- The call must invoke the default iterate routine of
|
||||||
|
-- the container and the transient object must appear as
|
||||||
|
-- the first actual parameter.
|
||||||
|
|
||||||
|
if Entity (Name (Call)) = Iter
|
||||||
|
and then Present (Parameter_Associations (Call))
|
||||||
|
then
|
||||||
|
Param := First (Parameter_Associations (Call));
|
||||||
|
|
||||||
|
if Nkind (Param) = N_Explicit_Dereference
|
||||||
|
and then Entity (Prefix (Param)) = Trans_Id
|
||||||
|
then
|
||||||
|
return True;
|
||||||
|
end if;
|
||||||
|
end if;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Next (Stmt);
|
||||||
|
end loop;
|
||||||
|
end if;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
return False;
|
||||||
|
end Is_Iterated_Container;
|
||||||
|
|
||||||
-- Start of processing for Is_Finalizable_Transient
|
-- Start of processing for Is_Finalizable_Transient
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
@ -4220,7 +4312,13 @@ package body Exp_Util is
|
||||||
|
|
||||||
-- Do not consider conversions of tags to class-wide types
|
-- Do not consider conversions of tags to class-wide types
|
||||||
|
|
||||||
and then not Is_Tag_To_CW_Conversion (Obj_Id);
|
and then not Is_Tag_To_CW_Conversion (Obj_Id)
|
||||||
|
|
||||||
|
-- Do not consider containers in the context of iterator loops. Such
|
||||||
|
-- transient objects must exist for as long as the loop is around,
|
||||||
|
-- otherwise any operation carried out by the iterator will fail.
|
||||||
|
|
||||||
|
and then not Is_Iterated_Container (Obj_Id, Decl);
|
||||||
end Is_Finalizable_Transient;
|
end Is_Finalizable_Transient;
|
||||||
|
|
||||||
---------------------------------
|
---------------------------------
|
||||||
|
|
|
@ -6119,10 +6119,16 @@ package body Sem_Ch8 is
|
||||||
-- is completed in the current scope, and not for a limited
|
-- is completed in the current scope, and not for a limited
|
||||||
-- view of a type.
|
-- view of a type.
|
||||||
|
|
||||||
if not Is_Tagged_Type (T)
|
if Ada_Version >= Ada_2005 then
|
||||||
and then Ada_Version >= Ada_2005
|
|
||||||
then
|
-- Test whether the Available_View of a limited type view
|
||||||
if From_With_Type (T) then
|
-- is tagged, since the limited view may not be marked as
|
||||||
|
-- tagged if the type itself has an untagged incomplete
|
||||||
|
-- type view in its package.
|
||||||
|
|
||||||
|
if From_With_Type (T)
|
||||||
|
and then not Is_Tagged_Type (Available_View (T))
|
||||||
|
then
|
||||||
Error_Msg_N
|
Error_Msg_N
|
||||||
("prefix of Class attribute must be tagged", N);
|
("prefix of Class attribute must be tagged", N);
|
||||||
Set_Etype (N, Any_Type);
|
Set_Etype (N, Any_Type);
|
||||||
|
|
Loading…
Reference in New Issue