From: Arnaud Charlet Date: Tue, 23 Apr 2013 09:53:23 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=e93f4e1244de0d4d7446237c7fa6995e57efca41;p=gcc.git [multiple changes] 2013-04-23 Vincent Celier * prj-part.ads, prj-conf.ads: Minor comment updates. 2013-04-23 Ed Schonberg * einfo.adb (Predicate_Function): For a private type, retrieve predicate function from full view. * aspects.adb (Find_Aspect): Ditto. * exp_ch6.adb (Expand_Actuals): If the formal is class-wide and the actual is a definite type, apply predicate check after call. * sem_res.adb: Do not apply a predicate check before the call to a generated Init_Proc. From-SVN: r198185 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b81550c7338..984e97d1523 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,17 @@ +2013-04-23 Vincent Celier + + * prj-part.ads, prj-conf.ads: Minor comment updates. + +2013-04-23 Ed Schonberg + + * einfo.adb (Predicate_Function): For a private type, retrieve + predicate function from full view. + * aspects.adb (Find_Aspect): Ditto. + * exp_ch6.adb (Expand_Actuals): If the formal is class-wide and + the actual is a definite type, apply predicate check after call. + * sem_res.adb: Do not apply a predicate check before the call to + a generated Init_Proc. + 2013-04-23 Robert Dewar * sem_ch13.adb (Analyze_Aspect_Specifications): Significant diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index f63cd2b387a..b72debb8600 100644 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -163,6 +163,12 @@ package body Aspects is if Is_Class_Wide_Type (Owner) and then Inherited_Aspect (A) then Owner := Root_Type (Owner); end if; + + if Is_Private_Type (Owner) + and then Present (Full_View (Owner)) + then + Owner := Full_View (Owner); + end if; end if; -- Search the representation items for the desired aspect diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 789a420704d..aa254f5f16d 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -7168,15 +7168,25 @@ package body Einfo is function Predicate_Function (Id : E) return E is S : Entity_Id; + T : Entity_Id; begin pragma Assert (Is_Type (Id)); - if No (Subprograms_For_Type (Id)) then + -- If type is private and has a completion, predicate may be defined + -- on the full view. + + if Is_Private_Type (Id) and then Present (Full_View (Id)) then + T := Full_View (Id); + else + T := Id; + end if; + + if No (Subprograms_For_Type (T)) then return Empty; else - S := Subprograms_For_Type (Id); + S := Subprograms_For_Type (T); while Present (S) loop if Is_Predicate_Function (S) then return S; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 08e93c4a4a9..bbb7bde6bc0 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -1720,15 +1720,19 @@ package body Exp_Ch6 is -- this is harder to verify, and there may be a redundant check. -- Note also that Subp may be either a subprogram entity for - -- direct calls, or a type entity for indirect calls, hence the - -- test that Is_Overloadable returns True before testing whether - -- Subp is an inherited operation. + -- direct calls, or a type entity for indirect calls, which must + -- be handled separately because the name does not denote an + -- overloadable entity. - if (Present (Find_Aspect (E_Actual, Aspect_Predicate)) + -- If the formal is class-wide the corresponding postcondition + -- procedure does not include a predicate call, so it has to be + -- generated explicitly. + + if (Has_Aspect (E_Actual, Aspect_Predicate) or else - Present (Find_Aspect (E_Actual, Aspect_Dynamic_Predicate)) + Has_Aspect (E_Actual, Aspect_Dynamic_Predicate) or else - Present (Find_Aspect (E_Actual, Aspect_Static_Predicate))) + Has_Aspect (E_Actual, Aspect_Static_Predicate)) and then not Is_Init_Proc (Subp) then if (Is_Derived_Type (E_Actual) @@ -1738,6 +1742,12 @@ package body Exp_Ch6 is then Append_To (Post_Call, Make_Predicate_Check (E_Actual, Actual)); + + elsif Is_Class_Wide_Type (E_Formal) + and then not Is_Class_Wide_Type (E_Actual) + then + Append_To + (Post_Call, Make_Predicate_Check (E_Actual, Actual)); end if; end if; diff --git a/gcc/ada/prj-conf.ads b/gcc/ada/prj-conf.ads index 172356f48ec..1c72fa769ba 100644 --- a/gcc/ada/prj-conf.ads +++ b/gcc/ada/prj-conf.ads @@ -89,8 +89,10 @@ package Prj.Conf is -- -- If Implicit_Project is True, the main project file being parsed is -- deemed to be in the current working directory, even if it is not the - -- case. - -- Why is this ever useful??? + -- case. Implicit_Project is set to True when a tool such as gprbuild is + -- invoked without a project file and is using an implicit project file + -- that is virtually in the current working directory, but is physically + -- in another directory. procedure Process_Project_And_Apply_Config (Main_Project : out Prj.Project_Id; diff --git a/gcc/ada/prj-part.ads b/gcc/ada/prj-part.ads index 438ec9dda94..1bf1366fb5c 100644 --- a/gcc/ada/prj-part.ads +++ b/gcc/ada/prj-part.ads @@ -70,7 +70,9 @@ package Prj.Part is -- -- If Implicit_Project is True, the main project file being parsed is -- deemed to be in the current working directory, even if it is not the - -- case. - -- Why is this ever useful??? + -- case. Implicit_Project is set to True when a tool such as gprbuild is + -- invoked without a project file and is using an implicit project file + -- that is virtually in the current working directory, but is physically + -- in another directory. end Prj.Part; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index db6ecf7ecfb..ee2483bc53b 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -3946,12 +3946,13 @@ package body Sem_Res is -- Apply predicate checks, unless this is a call to the -- predicate check function itself, which would cause an - -- infinite recursion. + -- infinite recursion, or it is a call to an initialization + -- procedure whose operand is of course an unfinished object. if not (Ekind (Nam) = E_Function and then (Is_Predicate_Function (Nam) - or else - Is_Predicate_Function_M (Nam))) + or else Is_Predicate_Function_M (Nam))) + and then not Is_Init_Proc (Nam) then Apply_Predicate_Check (A, F_Typ); end if;