diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 20 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 198 | ||||
| -rw-r--r-- | gcc/ada/checks.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/g-dyntab.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 6 |
8 files changed, 239 insertions, 18 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d01469f..bfc46b9 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,23 @@ +2017-04-27 Yannick Moy <moy@adacore.com> + + * sem_res.adb: Remove duplicate code. + * sem_attr.adb: Delete duplicate code. + +2017-04-27 Bob Duff <duff@adacore.com> + + * g-dyntab.adb: Reduce the amount of copying in + Release. No need to copy items past Last. + +2017-04-27 Hristian Kirtchev <kirtchev@adacore.com> + + * checks.adb Add with and use clauses for Sem_Disp. + (Install_Primitive_Elaboration_Check): New routine. + * checks.ads (Install_Primitive_Elaboration_Check): New routine. + * exp_attr.adb (Expand_N_Attribute_Reference): Clean up the + processing of 'Elaborated. + * exp_ch6.adb (Expand_N_Subprogram_Body): Install a primitive + elaboration check. + 2017-04-27 Bob Duff <duff@adacore.com> * g-dyntab.ads, g-dyntab.adb, g-table.ads: Remove incorrect assertion. diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 8ed4893..d9a36df 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -48,6 +48,7 @@ with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Ch3; use Sem_Ch3; with Sem_Ch8; use Sem_Ch8; +with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; @@ -7734,6 +7735,203 @@ package body Checks is Mark_Non_Null; end Install_Null_Excluding_Check; + ----------------------------------------- + -- Install_Primitive_Elaboration_Check -- + ----------------------------------------- + + procedure Install_Primitive_Elaboration_Check (Subp_Body : Node_Id) is + + function Within_Compilation_Unit_Instance + (Subp_Id : Entity_Id) return Boolean; + -- Determine whether subprogram Subp_Id appears within an instance which + -- acts as a compilation unit. + + -------------------------------------- + -- Within_Compilation_Unit_Instance -- + -------------------------------------- + + function Within_Compilation_Unit_Instance + (Subp_Id : Entity_Id) return Boolean + is + Pack : Entity_Id; + + begin + -- Examine the scope chain looking for a compilation-unit-level + -- instance. + + Pack := Scope (Subp_Id); + while Present (Pack) and then Pack /= Standard_Standard loop + if Ekind (Pack) = E_Package + and then Is_Generic_Instance (Pack) + and then Nkind (Parent (Unit_Declaration_Node (Pack))) = + N_Compilation_Unit + then + return True; + end if; + + Pack := Scope (Pack); + end loop; + + return False; + end Within_Compilation_Unit_Instance; + + -- Local declarations + + Context : constant Node_Id := Parent (Subp_Body); + Loc : constant Source_Ptr := Sloc (Subp_Body); + Subp_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Body); + Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); + + Decls : List_Id; + Flag_Id : Entity_Id; + Set_Ins : Node_Id; + Tag_Typ : Entity_Id; + + -- Start of processing for Install_Primitive_Elaboration_Check + + begin + -- Do not generate an elaboration check in compilation modes where + -- expansion is not desirable. + + if ASIS_Mode or GNATprove_Mode then + return; + + -- Do not generate an elaboration check if the related subprogram is + -- not subjected to accessibility checks. + + elsif Elaboration_Checks_Suppressed (Subp_Id) then + return; + + -- Do not consider subprograms which act as compilation units, because + -- they cannot be the target of a dispatching call. + + elsif Nkind (Context) = N_Compilation_Unit then + return; + + -- Only nonabstract library-level source primitives are considered for + -- this check. + + elsif not + (Comes_From_Source (Subp_Id) + and then Is_Library_Level_Entity (Subp_Id) + and then Is_Primitive (Subp_Id) + and then not Is_Abstract_Subprogram (Subp_Id)) + then + return; + + -- Do not consider inlined primitives, because once the body is inlined + -- the reference to the elaboration flag will be out of place and will + -- result in an undefined symbol. + + elsif Is_Inlined (Subp_Id) or else Has_Pragma_Inline (Subp_Id) then + return; + + -- Do not generate a duplicate elaboration check. This happens only in + -- the case of primitives completed by an expression function, as the + -- corresponding body is apparently analyzed and expanded twice. + + elsif Analyzed (Subp_Body) then + return; + + -- Do not consider primitives which occur within an instance that acts + -- as a compilation unit. Such an instance defines its spec and body out + -- of order (body is first) within the tree, which causes the reference + -- to the elaboration flag to appear as an undefined symbol. + + elsif Within_Compilation_Unit_Instance (Subp_Id) then + return; + end if; + + Tag_Typ := Find_Dispatching_Type (Subp_Id); + + -- Only tagged primitives may be the target of a dispatching call + + if No (Tag_Typ) then + return; + + -- Do not consider finalization-related primitives, because they may + -- need to be called while elaboration is taking place. + + elsif Is_Controlled (Tag_Typ) + and then Nam_In (Chars (Subp_Id), Name_Adjust, + Name_Finalize, + Name_Initialize) + then + return; + end if; + + -- Create the declaration of the elaboration flag. The name carries a + -- unique counter in case of name overloading. + + Flag_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Subp_Id), 'F', -1)); + Set_Is_Frozen (Flag_Id); + + -- Insert the declaration of the elaboration flag in front of the + -- primitive spec and analyze it in the proper context. + + Push_Scope (Scope (Subp_Id)); + + -- Generate: + -- F : Boolean := False; + + Insert_Action (Subp_Decl, + Make_Object_Declaration (Loc, + Defining_Identifier => Flag_Id, + Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), + Expression => New_Occurrence_Of (Standard_False, Loc))); + Pop_Scope; + + -- Prevent the compiler from optimizing the elaboration check by killing + -- the current value of the flag and the associated assignment. + + Set_Current_Value (Flag_Id, Empty); + Set_Last_Assignment (Flag_Id, Empty); + + -- Add a check at the top of the body declarations to ensure that the + -- elaboration flag has been set. + + Decls := Declarations (Subp_Body); + + if No (Decls) then + Decls := New_List; + Set_Declarations (Subp_Body, Decls); + end if; + + -- Generate: + -- if not F then + -- raise Program_Error with "access before elaboration"; + -- end if; + + Prepend_To (Decls, + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => New_Occurrence_Of (Flag_Id, Loc)), + Reason => PE_Access_Before_Elaboration)); + + Analyze (First (Decls)); + + -- Set the elaboration flag once the body has been elaborated. Insert + -- the statement after the subprogram stub when the primitive body is + -- a subunit. + + if Nkind (Context) = N_Subunit then + Set_Ins := Corresponding_Stub (Context); + else + Set_Ins := Subp_Body; + end if; + + -- Generate: + -- F := True; + + Insert_After_And_Analyze (Set_Ins, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Flag_Id, Loc), + Expression => New_Occurrence_Of (Standard_True, Loc))); + end Install_Primitive_Elaboration_Check; + -------------------------- -- Install_Static_Check -- -------------------------- diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index ff513e6..2c8ac1b 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -337,6 +337,12 @@ package Checks is -- Determines whether an access node requires a runtime access check and -- if so inserts the appropriate run-time check. + procedure Install_Primitive_Elaboration_Check (Subp_Body : Node_Id); + -- Insert a check which ensures that subprogram body Subp_Body has been + -- properly elaborated. The check is installed only when Subp_Body is the + -- body of a nonabstract library-level primitive of a tagged type. Further + -- restrictions may apply, see the body for details. + function Make_Bignum_Block (Loc : Source_Ptr) return Node_Id; -- This function is used by top level overflow checking routines to do a -- mark/release operation on the secondary stack around bignum operations. diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 56a92d3..ad6ab41 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -3025,16 +3025,15 @@ package body Exp_Attr is -- Note: The Elaborated attribute is never passed to the back end when Attribute_Elaborated => Elaborated : declare - Ent : constant Entity_Id := Entity (Pref); + Elab_Id : constant Entity_Id := Elaboration_Entity (Entity (Pref)); begin - if Present (Elaboration_Entity (Ent)) then + if Present (Elab_Id) then Rewrite (N, Make_Op_Ne (Loc, - Left_Opnd => - New_Occurrence_Of (Elaboration_Entity (Ent), Loc), - Right_Opnd => - Make_Integer_Literal (Loc, Uint_0))); + Left_Opnd => New_Occurrence_Of (Elab_Id, Loc), + Right_Opnd => Make_Integer_Literal (Loc, Uint_0))); + Analyze_And_Resolve (N, Typ); else Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index d8443ac..fe47352 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -5632,6 +5632,13 @@ package body Exp_Ch6 is -- Set to encode entity names in package body before gigi is called Qualify_Entity_Names (N); + + -- If the body belongs to a nonabstract library-level source primitive + -- of a tagged type, install an elaboration check which ensures that a + -- dispatching call targeting the primitive will not execute the body + -- without it being previously elaborated. + + Install_Primitive_Elaboration_Check (N); end Expand_N_Subprogram_Body; ----------------------------------- diff --git a/gcc/ada/g-dyntab.adb b/gcc/ada/g-dyntab.adb index 7159059..eed1365 100644 --- a/gcc/ada/g-dyntab.adb +++ b/gcc/ada/g-dyntab.adb @@ -348,7 +348,7 @@ package body GNAT.Dynamic_Tables is New_Table : constant Alloc_Ptr := new Alloc_Type; begin - New_Table (Alloc_Type'Range) := Old_Table (Alloc_Type'Range); + New_Table (First .. Last (T)) := Old_Table (First .. Last (T)); T.P.Last_Allocated := New_Last_Alloc; Free (Old_Table); T.Table := To_Table_Ptr (New_Table); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 0184d8e..ca43d06 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -9662,9 +9662,6 @@ package body Sem_Attr is elsif Is_Access_Type (Typ) then Id := RE_Type_Class_Access; - elsif Is_Enumeration_Type (Typ) then - Id := RE_Type_Class_Enumeration; - elsif Is_Task_Type (Typ) then Id := RE_Type_Class_Task; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 132fe67..257237e 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6797,12 +6797,6 @@ package body Sem_Res is return; end if; - -- For Standard.Wide_Wide_Character or a type derived from it, we - -- know the literal is in range, since the parser checked. - - elsif Root_Type (B_Typ) = Standard_Wide_Wide_Character then - return; - -- If the entity is already set, this has already been resolved in a -- generic context, or comes from expansion. Nothing else to do. |