diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1728be4adfc..697ea3dbba2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,29 @@ +2011-12-20 Hristian Kirtchev + + * 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 + + * 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 + + * 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 + + * exp_imgv.adb (Expand_Width_Attribute): Add a + type conversion from the enumeration subtype to its base subtype. + 2011-12-20 Hristian Kirtchev * sem_ch4.adb (Operator_Check): Update the call to diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index b2bf98cd1db..f38ff854640 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1913,49 +1913,57 @@ package body Exp_Ch11 is H := First (Exception_Handlers (P)); 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)); - while Present (C) loop + if Nkind (H) = N_Exception_Handler then - -- 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 - -- 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). + -- Deal with others case - if No (Choice_Parameter (H)) then - return H; - else - return Empty; - end if; + if Nkind (C) = N_Others_Choice then - -- 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 return H; else return Empty; end if; - end if; - end if; - Next (C); - end loop; + -- If not others must be entity name + + 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); end loop; diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index c8529ce2a51..f2e22f768b7 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -1177,7 +1177,7 @@ package body Exp_Imgv is -- ... -- 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 -- 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), Expression => Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Rtyp, Loc), - Attribute_Name => Name_Pos, - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Ptyp, Loc), - Attribute_Name => Name_Last))))); + Prefix => New_Occurrence_Of (Rtyp, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Convert_To (Rtyp, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Attribute_Name => Name_Last)))))); -- OK, now we need to build the conditional expression. First -- get the value of M, the largest possible value needed. diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 52541ed67eb..dd5fc9891f9 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; use Aspects; with Atree; use Atree; with Casing; use Casing; with Checks; use Checks; @@ -3966,6 +3967,13 @@ package body Exp_Util is function Is_Allocated (Trans_Id : Entity_Id) return Boolean; -- 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 -- --------------------------- @@ -4180,6 +4188,90 @@ package body Exp_Util is and then Nkind (Expr) = N_Allocator; 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 begin @@ -4220,7 +4312,13 @@ package body Exp_Util is -- 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; --------------------------------- diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 79fe3680e19..8134973d800 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -6119,10 +6119,16 @@ package body Sem_Ch8 is -- is completed in the current scope, and not for a limited -- view of a type. - if not Is_Tagged_Type (T) - and then Ada_Version >= Ada_2005 - then - if From_With_Type (T) then + if Ada_Version >= Ada_2005 then + + -- Test whether the Available_View of a limited type view + -- 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 ("prefix of Class attribute must be tagged", N); Set_Etype (N, Any_Type);