diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 46 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 125 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 39 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 23 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 138 | ||||
| -rw-r--r-- | gcc/ada/sem_res.ads | 14 | ||||
| -rw-r--r-- | gcc/ada/sem_type.adb | 13 |
8 files changed, 385 insertions, 22 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1dfd423..a5892f2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,49 @@ +2011-08-30 Gary Dismukes <dismukes@adacore.com> + + * sem_ch6.adb (Check_Return_Subtype_Indication): Issue error if the + return object has an anonymous access type and the function's type is + a named access type. + * sem_ch8.adb (Analyze_Object_Renaming): Suppress error about renaming + conversions on implicit conversions, since such conversions can occur + for anonymous access cases due to expansion. Issue error for attempt + to rename an anonymous expression as an object of a named access type. + * sem_res.ads (Valid_Conversion): Add defaulted parameter Report_Errs, + to indicate whether this function should report errors on invalid + conversions. + * sem_res.adb (Resolve): For Ada 2012, in the case where the type of + the expression is of an anonymous access type and the expected type is + a named general access type, rewrite the expression as a type + conversion, unless this is an expression of a membership test. + (Valid_Conversion.Error_Msg_N): New procedure that conditions the + calling of Error_Msg_N on new formal Report_Errs. + (Valid_Conversion.Error_Msg_NE): New procedure that conditions the + calling of Error_Msg_NE on new formal Report_Errs. + (Valid_Conversion): Move declaration of this function to the package + spec, to allow calls from membership test processing. For Ada 2012, + enforce legality restrictions on implicit conversions of anonymous + access values to general access types, disallowing such conversions in + cases where the expression has a dynamic accessibility level (access + parameters, stand-alone anonymous access objects, or a component of a + dereference of one of the first two cases). + * sem_type.adb (Covers): For Ada 2012, allow an anonymous access type + in the context of a named general access expected type. + * exp_ch4.adb Add with and use of Exp_Ch2. + (Expand_N_In): Add processing for membership tests applied to + expressions of an anonymous access type. First, Valid_Conversion is + called to check whether the test is statically False, and then the + conversion is expanded to test that the expression's accessibility + level is no deeper than that of the tested type. In the case of + anonymous access-to-tagged types, a tagged membership test is applied + as well. + (Tagged_Membership): Extend to handle access type cases, applying the + test to the designated types. + * exp_ch6.adb (Expand_Call): When creating an extra actual for an + accessibility level, and the actual is a 'Access applied to a current + instance, pass the accessibility level of the type of the current + instance rather than applying Object_Access_Level to the prefix. Add a + ??? comment, since this level isn't quite right either (will eventually + need to pass an implicit level parameter to init procs). + 2011-08-30 Bob Duff <duff@adacore.com> * s-taskin.ads: Minor comment fix. diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index e3f9412..e21d9d1 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -31,6 +31,7 @@ with Elists; use Elists; with Errout; use Errout; with Exp_Aggr; use Exp_Aggr; with Exp_Atag; use Exp_Atag; +with Exp_Ch2; use Exp_Ch2; with Exp_Ch3; use Exp_Ch3; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; @@ -4955,6 +4956,121 @@ package body Exp_Ch4 is Rewrite (N, Cond); Analyze_And_Resolve (N, Restyp); end if; + + -- Ada 2012 (AI05-0149): Handle membership tests applied to an + -- expression of an anonymous access type. This can involve an + -- accessibility test and a tagged type membership test in the + -- case of tagged designated types. + + if Ada_Version >= Ada_2012 + and then Is_Acc + and then Ekind (Ltyp) = E_Anonymous_Access_Type + then + declare + Expr_Entity : Entity_Id := Empty; + New_N : Node_Id; + Param_Level : Node_Id; + Type_Level : Node_Id; + begin + if Is_Entity_Name (Lop) then + Expr_Entity := Param_Entity (Lop); + if not Present (Expr_Entity) then + Expr_Entity := Entity (Lop); + end if; + end if; + + -- If a conversion of the anonymous access value to the + -- tested type would be illegal, then the result is False. + + if not Valid_Conversion + (Lop, Rtyp, Lop, Report_Errs => False) + then + Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); + Analyze_And_Resolve (N, Restyp); + + -- Apply an accessibility check if the access object has an + -- associated access level and when the level of the type is + -- less deep than the level of the access parameter. This + -- only occur for access parameters and stand-alone objects + -- of an anonymous access type. + + else + if Present (Expr_Entity) + and then Present (Extra_Accessibility (Expr_Entity)) + and then UI_Gt + (Object_Access_Level (Lop), + Type_Access_Level (Rtyp)) + then + Param_Level := + New_Occurrence_Of + (Extra_Accessibility (Expr_Entity), Loc); + + Type_Level := + Make_Integer_Literal (Loc, Type_Access_Level (Rtyp)); + + -- Return True only if the accessibility level of the + -- expression entity is not deeper than the level of + -- the tested access type. + + Rewrite (N, + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (N), + Right_Opnd => Make_Op_Le (Loc, + Left_Opnd => Param_Level, + Right_Opnd => Type_Level))); + + Analyze_And_Resolve (N); + end if; + + -- If the designated type is tagged, do tagged membership + -- operation. + + -- *** NOTE: we have to check not null before doing the + -- tagged membership test (but maybe that can be done + -- inside Tagged_Membership?). + + if Is_Tagged_Type (Typ) then + Rewrite (N, + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (N), + Right_Opnd => + Make_Op_Ne (Loc, + Left_Opnd => Obj, + Right_Opnd => Make_Null (Loc)))); + + -- No expansion will be performed when VM_Target, as + -- the VM back-ends will handle the membership tests + -- directly (tags are not explicitly represented in + -- Java objects, so the normal tagged membership + -- expansion is not what we want). + + if Tagged_Type_Expansion then + + -- Note that we have to pass Original_Node, because + -- the membership test might already have been + -- rewritten by earlier parts of membership test. + + Tagged_Membership + (Original_Node (N), SCIL_Node, New_N); + + -- Update decoration of relocated node referenced + -- by the SCIL node. + + if Generate_SCIL and then Present (SCIL_Node) then + Set_SCIL_Node (New_N, SCIL_Node); + end if; + + Rewrite (N, + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (N), + Right_Opnd => New_N)); + + Analyze_And_Resolve (N, Restyp); + end if; + end if; + end if; + end; + end if; end; end if; @@ -10909,6 +11025,15 @@ package body Exp_Ch4 is Left_Type := Available_View (Etype (Left)); Right_Type := Available_View (Etype (Right)); + -- In the case where the type is an access type, the test is applied + -- using the designated types (needed in Ada 2012 for implicit anonymous + -- access conversions, for AI05-0149). + + if Is_Access_Type (Right_Type) then + Left_Type := Designated_Type (Left_Type); + Right_Type := Designated_Type (Right_Type); + end if; + if Is_Class_Wide_Type (Left_Type) then Left_Type := Root_Type (Left_Type); end if; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 8073ff5..93d8174 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2436,12 +2436,39 @@ package body Exp_Ch6 is -- For X'Access, pass on the level of the prefix X when Attribute_Access => - Add_Extra_Actual - (Make_Integer_Literal (Loc, - Intval => - Object_Access_Level - (Prefix (Prev_Orig))), - Extra_Accessibility (Formal)); + -- If this is an Access attribute applied to the + -- the current instance object passed to a type + -- initialization procedure, then use the level + -- of the type itself. This is not really correct, + -- as there should be an extra level parameter + -- passed in with _init formals (only in the case + -- where the type is immutably limited), but we + -- don't have an easy way currently to create such + -- an extra formal (init procs aren't ever frozen). + -- For now we just use the level of the type, + -- which may be too shallow, but that works better + -- than passing Object_Access_Level of the type, + -- which can be one level too deep in some cases. + -- ??? + + if Is_Entity_Name (Prefix (Prev_Orig)) + and then Is_Type (Entity (Prefix (Prev_Orig))) + then + Add_Extra_Actual + (Make_Integer_Literal (Loc, + Intval => + Type_Access_Level + (Entity (Prefix (Prev_Orig)))), + Extra_Accessibility (Formal)); + + else + Add_Extra_Actual + (Make_Integer_Literal (Loc, + Intval => + Object_Access_Level + (Prefix (Prev_Orig))), + Extra_Accessibility (Formal)); + end if; -- Treat the unchecked attributes as library-level diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 4c19666..f7e0fa5 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -564,6 +564,15 @@ package body Sem_Ch6 is Error_Msg_N ("must use anonymous access type", Subtype_Ind); end if; + -- If the return object is of an anonymous access type, then report + -- an error if the function's result type is not also anonymous. + + elsif R_Stm_Type_Is_Anon_Access + and then not R_Type_Is_Anon_Access + then + Error_Msg_N ("anonymous access not allowed for function with " & + "named access result", Subtype_Ind); + -- Subtype indication case: check that the return object's type is -- covered by the result type, and that the subtypes statically match -- when the result subtype is constrained. Also handle record types diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 77f948f..662a0e9 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -802,8 +802,13 @@ package body Sem_Ch8 is T := Entity (Subtype_Mark (N)); Analyze (Nam); + -- Reject renamings of conversions unless the type is tagged, or + -- the conversion is implicit (which can occur for cases of anonymous + -- access types in Ada 2012). + if Nkind (Nam) = N_Type_Conversion - and then not Is_Tagged_Type (T) + and then Comes_From_Source (Nam) + and then not Is_Tagged_Type (T) then Error_Msg_N ("renaming of conversion only allowed for tagged types", Nam); @@ -834,6 +839,22 @@ package body Sem_Ch8 is return; end if; + -- Ada 2012 (AI05-149): Reject renaming of an anonymous access object + -- when renaming declaration has a named access type. The Ada 2012 + -- coverage rules allow an anonymous access type in the context of + -- an expected named general access type, but the renaming rules + -- require the types to be the same. (An exception is when the type + -- of the renaming is also an anonymous access type, which can only + -- happen due to a renaming created by the expander.) + + if Nkind (Nam) = N_Type_Conversion + and then not Comes_From_Source (Nam) + and then Ekind (Etype (Expression (Nam))) = E_Anonymous_Access_Type + and then Ekind (T) /= E_Anonymous_Access_Type + then + Wrong_Type (Expression (Nam), T); -- Should we give better error??? + end if; + -- Check that a class-wide object is not being renamed as an object -- of a specific type. The test for access types is needed to exclude -- cases where the renamed object is a dynamically tagged access diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 409ace4..0d03b29 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -273,15 +273,6 @@ package body Sem_Res is -- is only one requires a search over all visible entities, and happens -- only in very pathological cases (see 6115-006). - function Valid_Conversion - (N : Node_Id; - Target : Entity_Id; - Operand : Node_Id) return Boolean; - -- Verify legality rules given in 4.6 (8-23). Target is the target type - -- of the conversion, which may be an implicit conversion of an actual - -- parameter to an anonymous access type (in which case N denotes the - -- actual parameter and N = Operand). - ------------------------- -- Ambiguous_Character -- ------------------------- @@ -2759,6 +2750,22 @@ package body Sem_Res is Resolve_Unchecked_Type_Conversion (N, Ctx_Type); end case; + -- Ada 2012 (AI05-0149): Apply an (implicit) conversion to an + -- expression of an anonymous access type that occurs in the context + -- of a named general access type, except when the expression is that + -- of a membership test. This ensures proper legality checking in + -- terms of allowed conversions (expressions that would be illegal to + -- convert implicitly are allowed in membership tests). + + if Ada_Version >= Ada_2012 + and then Ekind (Ctx_Type) = E_General_Access_Type + and then Ekind (Etype (N)) = E_Anonymous_Access_Type + and then Nkind (Parent (N)) not in N_Membership_Test + then + Rewrite (N, Convert_To (Ctx_Type, Relocate_Node (N))); + Analyze_And_Resolve (N, Ctx_Type); + end if; + -- If the subexpression was replaced by a non-subexpression, then -- all we do is to expand it. The only legitimate case we know of -- is converting procedure call statement to entry call statements, @@ -10097,9 +10104,10 @@ package body Sem_Res is ---------------------- function Valid_Conversion - (N : Node_Id; - Target : Entity_Id; - Operand : Node_Id) return Boolean + (N : Node_Id; + Target : Entity_Id; + Operand : Node_Id; + Report_Errs : Boolean := True) return Boolean is Target_Type : constant Entity_Id := Base_Type (Target); Opnd_Type : Entity_Id := Etype (Operand); @@ -10109,6 +10117,15 @@ package body Sem_Res is Msg : String) return Boolean; -- Little routine to post Msg if Valid is False, returns Valid value + procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id); + -- If Report_Errs, then calls Errout.Error_Msg_N with its arguments + + procedure Error_Msg_NE + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id); + -- If Report_Errs, then calls Errout.Error_Msg_NE with its arguments + function Valid_Tagged_Conversion (Target_Type : Entity_Id; Opnd_Type : Entity_Id) return Boolean; @@ -10134,6 +10151,32 @@ package body Sem_Res is return Valid; end Conversion_Check; + ----------------- + -- Error_Msg_N -- + ----------------- + + procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is + begin + if Report_Errs then + Errout.Error_Msg_N (Msg, N); + end if; + end Error_Msg_N; + + ------------------ + -- Error_Msg_NE -- + ------------------ + + procedure Error_Msg_NE + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id) + is + begin + if Report_Errs then + Errout.Error_Msg_NE (Msg, N, E); + end if; + end Error_Msg_NE; + ---------------------------- -- Valid_Array_Conversion -- ---------------------------- @@ -10588,9 +10631,76 @@ package body Sem_Res is if Ekind (Target_Type) /= E_Anonymous_Access_Type or else Is_Local_Anonymous_Access (Target_Type) then - if Type_Access_Level (Opnd_Type) - > Type_Access_Level (Target_Type) + -- Ada 2012 (AI05-0149): Perform legality checking on implicit + -- conversions from an anonymous access type to a named general + -- access type. Such conversions are not allowed in the case of + -- access parameters and stand-alone objects of an anonymous + -- access type. + + if Ada_Version >= Ada_2012 + and then not Comes_From_Source (N) + and then Ekind (Target_Type) = E_General_Access_Type + and then Ekind (Opnd_Type) = E_Anonymous_Access_Type then + if Is_Itype (Opnd_Type) then + + -- Implicit conversions aren't allowed for objects of an + -- anonymous access type, since such objects have nonstatic + -- levels in Ada 2012. + + if Nkind (Associated_Node_For_Itype (Opnd_Type)) = + N_Object_Declaration + then + Error_Msg_N + ("implicit conversion of stand-alone anonymous " & + "access object not allowed", Operand); + return False; + + -- Implicit conversions aren't allowed for anonymous access + -- parameters. The "not Is_Local_Anonymous_Access_Type" test + -- is done to exclude anonymous access results. + + elsif not Is_Local_Anonymous_Access (Opnd_Type) + and then Nkind_In (Associated_Node_For_Itype (Opnd_Type), + N_Function_Specification, + N_Procedure_Specification) + then + Error_Msg_N + ("implicit conversion of anonymous access formal " & + "not allowed", Operand); + return False; + + -- This is a case where there's an enclosing object whose + -- to which the "statically deeper than" relationship does + -- not apply (such as an access discriminant selected from + -- a dereference of an access parameter). + + elsif Object_Access_Level (Operand) + = Scope_Depth (Standard_Standard) + then + Error_Msg_N + ("implicit conversion of anonymous access value " & + "not allowed", Operand); + return False; + + -- In other cases, the level of the operand's type must be + -- statically less deep than that of the target type, else + -- implicit conversion is disallowed (by RM12-8.6(27.1/3)). + + elsif Type_Access_Level (Opnd_Type) + > Type_Access_Level (Target_Type) + then + Error_Msg_N + ("implicit conversion of anonymous access value " & + "violates accessibility", Operand); + return False; + end if; + end if; + + elsif Type_Access_Level (Opnd_Type) + > Type_Access_Level (Target_Type) + then + -- In an instance, this is a run-time check, but one we know -- will fail, so generate an appropriate warning. The raise -- will be generated by Expand_N_Type_Conversion. diff --git a/gcc/ada/sem_res.ads b/gcc/ada/sem_res.ads index 70b534b..361b865 100644 --- a/gcc/ada/sem_res.ads +++ b/gcc/ada/sem_res.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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- -- @@ -122,6 +122,18 @@ package Sem_Res is procedure Preanalyze_And_Resolve (N : Node_Id); -- Same, but use type of node because context does not impose a single type + function Valid_Conversion + (N : Node_Id; + Target : Entity_Id; + Operand : Node_Id; + Report_Errs : Boolean := True) return Boolean; + -- Verify legality rules given in 4.6 (8-23). Target is the target type + -- of the conversion, which may be an implicit conversion of an actual + -- parameter to an anonymous access type (in which case N denotes the + -- actual parameter and N = Operand). Returns a Boolean result indicating + -- whether the conversion is legal. Reports errors in the case of illegal + -- conversions, unless Report_Errs is False. + private procedure Resolve_Implicit_Type (N : Node_Id) renames Resolve; pragma Inline (Resolve_Implicit_Type); diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 70a9423..8c2eeee 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -967,6 +967,19 @@ package body Sem_Type is then return True; + -- Ada 2012 (AI05-0149): Allow an anonymous access type in the context + -- of a named general access type. An implicit conversion will be + -- applied. For the resolution, one designated type must cover the + -- other. + + elsif Ada_Version >= Ada_2012 + and then Ekind (BT1) = E_General_Access_Type + and then Ekind (BT2) = E_Anonymous_Access_Type + and then (Covers (Designated_Type (T1), Designated_Type (T2)) + or else Covers (Designated_Type (T2), Designated_Type (T1))) + then + return True; + -- An Access_To_Subprogram is compatible with itself, or with an -- anonymous type created for an attribute reference Access. |