From: Arnaud Charlet Date: Wed, 22 Jun 2016 10:37:08 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=405b907c8fb5f183d2ae2a0f65f750a1551ef97c;p=gcc.git [multiple changes] 2016-06-22 Ed Schonberg * einfo.ads, einfo.adb (Is_Actual_Subtype): New flag, defined on subtypes that are created within subprogram bodies to handle unconstrained composite formals. * checks.adb (Apply_Predicate_Check): Do not generate a check on an object whose type is an actual subtype. * sem_ch6.adb (Set_Actual_Subtypes): Do not generate an actual subtype for a formal whose base type is private. Set Is_Actual_Subtype on corresponding entity after analyzing its declaration. 2016-06-22 Justin Squirek * sem_prag.adb (Check_Expr_Is_OK_Static_Expression): Fix ordering of if-block and add in a condition to test for errors during resolution. * sem_res.adb (Resolution_Failed): Add comment to explain why the type of a node which failed to resolve is set to the desired type instead of Any_Type. * sem_ch8.adb (Analyze_Object_Renaming): Add a check for Any_Type to prevent crashes on Is_Access_Constant. From-SVN: r237692 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6d4bf1ed76d..2a9fce93418 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,26 @@ +2016-06-22 Ed Schonberg + + * einfo.ads, einfo.adb (Is_Actual_Subtype): New flag, defined + on subtypes that are created within subprogram bodies to handle + unconstrained composite formals. + * checks.adb (Apply_Predicate_Check): Do not generate a check on + an object whose type is an actual subtype. + * sem_ch6.adb (Set_Actual_Subtypes): Do not generate an + actual subtype for a formal whose base type is private. + Set Is_Actual_Subtype on corresponding entity after analyzing + its declaration. + +2016-06-22 Justin Squirek + + * sem_prag.adb (Check_Expr_Is_OK_Static_Expression): Fix ordering + of if-block and add in a condition to test for errors during + resolution. + * sem_res.adb (Resolution_Failed): Add comment to explain why + the type of a node which failed to resolve is set to the desired + type instead of Any_Type. + * sem_ch8.adb (Analyze_Object_Renaming): Add a check for Any_Type + to prevent crashes on Is_Access_Constant. + 2016-06-22 Hristian Kirtchev * lib-xref-spark_specific.adb, checks.adb, sem_ch13.adb: Minor diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index cde455f7b51..961e4b5a5f6 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -2650,7 +2650,17 @@ package body Checks is Check_Expression_Against_Static_Predicate (N, Typ); - if Is_Entity_Name (N) then + if not Expander_Active then + return; + end if; + + -- For an entity of the type, generate a call to the predicate + -- function, unless its type is an actual subtype, which is not + -- visible outside of the enclosing subprogram. + + if Is_Entity_Name (N) + and then not Is_Actual_Subtype (Typ) + then Insert_Action (N, Make_Predicate_Check (Typ, New_Occurrence_Of (Entity (N), Sloc (N)))); diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 6fa9f9a4fdb..fd01315215e 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -607,8 +607,8 @@ package body Einfo is -- Has_Inherited_Invariants Flag291 -- Is_Partial_Invariant_Procedure Flag292 + -- Is_Actual_Subtype Flag293 - -- (unused) Flag293 -- (unused) Flag294 -- (unused) Flag295 -- (unused) Flag296 @@ -2014,6 +2014,12 @@ package body Einfo is return Flag69 (Id); end Is_Access_Constant; + function Is_Actual_Subtype (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag293 (Id); + end Is_Actual_Subtype; + function Is_Ada_2005_Only (Id : E) return B is begin return Flag185 (Id); @@ -5036,6 +5042,12 @@ package body Einfo is Set_Flag69 (Id, V); end Set_Is_Access_Constant; + procedure Set_Is_Actual_Subtype (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag293 (Id, V); + end Set_Is_Actual_Subtype; + procedure Set_Is_Ada_2005_Only (Id : E; V : B := True) is begin Set_Flag185 (Id, V); @@ -9186,6 +9198,7 @@ package body Einfo is W ("Is_Abstract_Subprogram", Flag19 (Id)); W ("Is_Abstract_Type", Flag146 (Id)); W ("Is_Access_Constant", Flag69 (Id)); + W ("Is_Actual_Subtype", Flag293 (Id)); W ("Is_Ada_2005_Only", Flag185 (Id)); W ("Is_Ada_2012_Only", Flag199 (Id)); W ("Is_Aliased", Flag15 (Id)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 148e2dc433d..683c281e24f 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2232,6 +2232,10 @@ package Einfo is -- Is_Access_Type (synthesized) -- Applies to all entities, true for access types and subtypes +-- Is_Actual_Subtype (Flag293) +-- Defined on all types, true for the generated constrained subtypes +-- that are built for unconstrained composite actuals. + -- Is_Ada_2005_Only (Flag185) -- Defined in all entities, true if a valid pragma Ada_05 or Ada_2005 -- applies to the entity which specifically names the entity, indicating @@ -7017,6 +7021,7 @@ package Einfo is function Is_Abstract_Subprogram (Id : E) return B; function Is_Abstract_Type (Id : E) return B; function Is_Access_Constant (Id : E) return B; + function Is_Actual_Subtype (Id : E) return B; function Is_Ada_2005_Only (Id : E) return B; function Is_Ada_2012_Only (Id : E) return B; function Is_Aliased (Id : E) return B; @@ -7689,6 +7694,7 @@ package Einfo is procedure Set_Is_Abstract_Subprogram (Id : E; V : B := True); procedure Set_Is_Abstract_Type (Id : E; V : B := True); procedure Set_Is_Access_Constant (Id : E; V : B := True); + procedure Set_Is_Actual_Subtype (Id : E; V : B := True); procedure Set_Is_Ada_2005_Only (Id : E; V : B := True); procedure Set_Is_Ada_2012_Only (Id : E; V : B := True); procedure Set_Is_Aliased (Id : E; V : B := True); @@ -8477,6 +8483,7 @@ package Einfo is pragma Inline (Is_Abstract_Subprogram); pragma Inline (Is_Abstract_Type); pragma Inline (Is_Access_Constant); + pragma Inline (Is_Actual_Subtype); pragma Inline (Is_Access_Protected_Subprogram_Type); pragma Inline (Is_Access_Subprogram_Type); pragma Inline (Is_Access_Type); @@ -8989,6 +8996,7 @@ package Einfo is pragma Inline (Set_Is_Abstract_Subprogram); pragma Inline (Set_Is_Abstract_Type); pragma Inline (Set_Is_Access_Constant); + pragma Inline (Set_Is_Actual_Subtype); pragma Inline (Set_Is_Ada_2005_Only); pragma Inline (Set_Is_Ada_2012_Only); pragma Inline (Set_Is_Aliased); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 81b0ca787e4..81bffcb9b99 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -11226,9 +11226,12 @@ package body Sem_Ch6 is -- At this stage we have an unconstrained type that may need an -- actual subtype. For sure the actual subtype is needed if we have - -- an unconstrained array type. + -- an unconstrained array type. However, in an instance, the type + -- may appear as a subtype of the full view, while the actual is + -- in fact private (in which case no actual subtype is needed) so + -- check the kind of the base type. - elsif Is_Array_Type (T) then + elsif Is_Array_Type (Base_Type (T)) then AS_Needed := True; -- The only other case needing an actual subtype is an unconstrained @@ -11299,6 +11302,7 @@ package body Sem_Ch6 is -- therefore needs no constraint checks. Analyze (Decl, Suppress => All_Checks); + Set_Is_Actual_Subtype (Defining_Identifier (Decl)); -- We need to freeze manually the generated type when it is -- inserted anywhere else than in a declarative part. diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index a6900a3b9bd..44bae7d52e0 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -1022,22 +1022,30 @@ package body Sem_Ch8 is Resolve (Nam, T); + -- Do not perform the legality checks below when the resolution of + -- the renaming name failed because the associated type is Any_Type. + + if Etype (Nam) = Any_Type then + null; + -- Ada 2005 (AI-231): In the case where the type is defined by an -- access_definition, the renamed entity shall be of an access-to- -- constant type if and only if the access_definition defines an -- access-to-constant type. ARM 8.5.1(4) - if Constant_Present (Access_Definition (N)) + elsif Constant_Present (Access_Definition (N)) and then not Is_Access_Constant (Etype (Nam)) then - Error_Msg_N ("(Ada 2005): the renamed object is not " - & "access-to-constant (RM 8.5.1(6))", N); + Error_Msg_N + ("(Ada 2005): the renamed object is not access-to-constant " + & "(RM 8.5.1(6))", N); elsif not Constant_Present (Access_Definition (N)) and then Is_Access_Constant (Etype (Nam)) then - Error_Msg_N ("(Ada 2005): the renamed object is not " - & "access-to-variable (RM 8.5.1(6))", N); + Error_Msg_N + ("(Ada 2005): the renamed object is not access-to-variable " + & "(RM 8.5.1(6))", N); end if; if Is_Access_Subprogram_Type (Etype (Nam)) then diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index b856badbf92..c266e2d5d02 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -5060,12 +5060,15 @@ package body Sem_Prag is Analyze_And_Resolve (Expr); end if; - if Is_OK_Static_Expression (Expr) then - return; + -- An expression cannot be considered static if its resolution failed + -- or if it erroneous. Stop the analysis of the related pragma. - elsif Etype (Expr) = Any_Type then + if Etype (Expr) = Any_Type or else Error_Posted (Expr) then raise Pragma_Exit; + elsif Is_OK_Static_Expression (Expr) then + return; + -- An interesting special case, if we have a string literal and we -- are in Ada 83 mode, then we allow it even though it will not be -- flagged as static. This allows the use of Ada 95 pragmas like @@ -5077,12 +5080,6 @@ package body Sem_Prag is then return; - -- Static expression that raises Constraint_Error. This has already - -- been flagged, so just exit from pragma processing. - - elsif Is_OK_Static_Expression (Expr) then - raise Pragma_Exit; - -- Finally, we have a real error else diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index f6fb056d192..ffd2ea15fbd 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -1974,7 +1974,12 @@ package body Sem_Res is procedure Resolution_Failed is begin Patch_Up_Value (N, Typ); + + -- Set the type to the desired one to minimize cascaded errors. Note + -- that this is an approximation and does not work in all cases. + Set_Etype (N, Typ); + Debug_A_Exit ("resolving ", N, " (done, resolution failed)"); Set_Is_Overloaded (N, False);