diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 30 | ||||
| -rw-r--r-- | gcc/ada/contracts.adb | 79 | ||||
| -rw-r--r-- | gcc/ada/gnat1drv.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 19 |
7 files changed, 138 insertions, 8 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2ef1028a53e..c1be18cec01 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,33 @@ +2016-04-18 Ed Schonberg <schonberg@adacore.com> + + * sem_ch4.adb (Analyze_Selected_Component, Has_Dereference): + Refine check on illegal calls to entities within a task body, + when the entity is declared in an object of the same type. In + a generic context there might be no explicit dereference but if + the prefix includes an access type the construct is legal. + +2016-04-18 Arnaud Charlet <charlet@adacore.com> + + * rtsfind.ads, rtsfind.adb (RE_Id, RE_Unit_Table): add + RE_Default_Priority. + +2016-04-18 Bob Duff <duff@adacore.com> + + * sem_prag.adb (Check_Arg_Is_Local_Name): Don't do the check + if the pragma came from an aspect specification. + +2016-04-18 Gary Dismukes <dismukes@adacore.com> + + * gnat1drv.adb, contracts.adb: Minor reformatting and wording fixes. + +2016-04-18 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): To suppress + superfluous conformance check on an inlined body with a previous + spec, use the fact that the generated declaration does not come + from source. We must treat the entity as coming from source to + enable some back-end inlining when pragma appears after the body. + 2016-04-18 Gary Dismukes <dismukes@adacore.com> * lib-xref-spark_specific.adb, par-ch2.adb, errout.ads, diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index f937b687877..4a2121f72ca 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -2010,6 +2010,10 @@ package body Contracts is -- The insertion node after which all pragma Check equivalents are -- inserted. + function Is_Prologue_Renaming (Decl : Node_Id) return Boolean; + -- Determine whether arbitrary declaration Decl denotes a renaming of + -- a discriminant or protection field _object. + procedure Merge_Preconditions (From : Node_Id; Into : Node_Id); -- Merge two class-wide preconditions by "or else"-ing them. The -- changes are accumulated in parameter Into. Update the error @@ -2030,6 +2034,52 @@ package body Contracts is -- Collect all preconditions of subprogram Subp_Id and prepend their -- pragma Check equivalents to the declarations of the body. + -------------------------- + -- Is_Prologue_Renaming -- + -------------------------- + + function Is_Prologue_Renaming (Decl : Node_Id) return Boolean is + Nam : Node_Id; + Obj : Entity_Id; + Pref : Node_Id; + Sel : Node_Id; + + begin + if Nkind (Decl) = N_Object_Renaming_Declaration then + Obj := Defining_Entity (Decl); + Nam := Name (Decl); + + if Nkind (Nam) = N_Selected_Component then + Pref := Prefix (Nam); + Sel := Selector_Name (Nam); + + -- A discriminant renaming appears as + -- Discr : constant ... := Prefix.Discr; + + if Ekind (Obj) = E_Constant + and then Is_Entity_Name (Sel) + and then Present (Entity (Sel)) + and then Ekind (Entity (Sel)) = E_Discriminant + then + return True; + + -- A protection field renaming appears as + -- Prot : ... := _object._object; + + elsif Ekind (Obj) = E_Variable + and then Nkind (Pref) = N_Identifier + and then Chars (Pref) = Name_uObject + and then Nkind (Sel) = N_Identifier + and then Chars (Sel) = Name_uObject + then + return True; + end if; + end if; + end if; + + return False; + end Is_Prologue_Renaming; + ------------------------- -- Merge_Preconditions -- ------------------------- @@ -2278,15 +2328,34 @@ package body Contracts is -- Start of processing for Process_Preconditions begin - -- Find the last internally generated declaration, starting from the - -- top of the body declarations. This ensures that discriminals and - -- subtypes are properly visible to the pragma Check equivalents. + -- Find the proper insertion point for all pragma Check equivalents if Present (Decls) then Decl := First (Decls); while Present (Decl) loop - exit when Comes_From_Source (Decl); - Insert_Node := Decl; + + -- First source declaration terminates the search, because all + -- preconditions must be evaluated prior to it, by definition. + + if Comes_From_Source (Decl) then + exit; + + -- Certain internally generated object renamings such as those + -- for discriminants and protection fields must be elaborated + -- before the preconditions are evaluated, as their expressions + -- may mention the discriminants. + + elsif Is_Prologue_Renaming (Decl) then + Insert_Node := Decl; + + -- Otherwise the declaration does not come from source. This + -- also terminates the search, because internal code may raise + -- exceptions which should not preempt the preconditions. + + else + exit; + end if; + Next (Decl); end loop; end if; diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 8ecababab00..220ad93f129 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -1047,7 +1047,7 @@ begin -- In GNATprove mode, force loading of System unit to ensure that -- System.Interrupt_Priority is available to GNATprove for the - -- generation of VCs for related to Ceiling Priority. + -- generation of VCs related to ceiling priority. if GNATprove_Mode then declare diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 1d8cd89cc4c..842c65bc761 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -725,6 +725,7 @@ package Rtsfind is RE_Address, -- System RE_Any_Priority, -- System RE_Bit_Order, -- System + RE_Default_Priority, -- System RE_High_Order_First, -- System RE_Interrupt_Priority, -- System RE_Lib_Stop, -- System @@ -1957,6 +1958,7 @@ package Rtsfind is RE_Address => System, RE_Any_Priority => System, RE_Bit_Order => System, + RE_Default_Priority => System, RE_High_Order_First => System, RE_Interrupt_Priority => System, RE_Lib_Stop => System, diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index d7264ec977d..80e94319adb 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -4221,6 +4221,13 @@ package body Sem_Ch4 is if Nkind (Nod) = N_Explicit_Dereference then return True; + -- When expansion is disabled an explicit dereference may not have + -- been inserted, but if this is an access type the indirection makes + -- the call safe. + + elsif Is_Access_Type (Etype (Nod)) then + return True; + elsif Nkind_In (Nod, N_Indexed_Component, N_Selected_Component) then return Has_Dereference (Prefix (Nod)); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index f3686b30e37..86ff88175d1 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -3378,10 +3378,13 @@ package body Sem_Ch6 is Conformant := True; -- Conversely, the spec may have been generated for specless body - -- with an inline pragma. + -- with an inline pragma. The entity comes from source, which is + -- both semantically correct and necessary for proper inlining. + -- The subprogram declaration itself is not in the source. elsif Comes_From_Source (N) - and then not Comes_From_Source (Spec_Id) + and then Present (Spec_Decl) + and then not Comes_From_Source (Spec_Decl) and then Has_Pragma_Inline (Spec_Id) then Conformant := True; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index acf3f94d08c..b9c3c8bfe7b 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -4539,6 +4539,25 @@ package body Sem_Prag is Argx : constant Node_Id := Get_Pragma_Arg (Arg); begin + -- If this pragma came from an aspect specification, we don't want to + -- check for this error, because that would cause spurious errors, in + -- case a type is frozen in a scope more nested than the type. The + -- aspect itself of course can't be anywhere but on the declaration + -- itself. + + if Nkind (Arg) = N_Pragma_Argument_Association then + if From_Aspect_Specification (Parent (Arg)) then + return; + end if; + + -- Arg is the Expression of an N_Pragma_Argument_Association + + else + if From_Aspect_Specification (Parent (Parent (Arg))) then + return; + end if; + end if; + Analyze (Argx); if Nkind (Argx) not in N_Direct_Name |