From 3373589b25382e5389a189acc832fb657016f375 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 26 Oct 2015 14:37:54 +0100 Subject: [PATCH] [multiple changes] 2015-10-26 Ed Schonberg * sem_res.adb (Resolve_Generalized_Indexing): In ASIS mode, when restoring original node, remove Generalized_Indexing operation so that it is recreated during re- analysis. 2015-10-26 Javier Miranda * exp_unst.adb: (Unnest_Subprogram): Replace absolute references to 1 and 0 by their counterpart relative references through Subps_First. 2015-10-26 Ed Schonberg * par-ch3.adb (P_Declarative_Items): In case of misplaced aspect specifications, ensure that flag Done is properly set to continue parse. * sem_prag.adb, sem_prag.ads: Remove Build_Generic_Class_Condition, unused. From-SVN: r229362 --- gcc/ada/ChangeLog | 20 ++++ gcc/ada/exp_unst.adb | 12 +-- gcc/ada/par-ch3.adb | 5 + gcc/ada/sem_prag.adb | 249 ------------------------------------------- gcc/ada/sem_prag.ads | 11 -- gcc/ada/sem_res.adb | 2 + 6 files changed, 33 insertions(+), 266 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4f63dfe074e..4806519dd2b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,23 @@ +2015-10-26 Ed Schonberg + + * sem_res.adb (Resolve_Generalized_Indexing): In ASIS mode, when + restoring original node, remove Generalized_Indexing operation + so that it is recreated during re- analysis. + +2015-10-26 Javier Miranda + + * exp_unst.adb: (Unnest_Subprogram): + Replace absolute references to 1 and 0 by their counterpart + relative references through Subps_First. + +2015-10-26 Ed Schonberg + + * par-ch3.adb (P_Declarative_Items): In case of misplaced + aspect specifications, ensure that flag Done is properly set to + continue parse. + * sem_prag.adb, sem_prag.ads: Remove Build_Generic_Class_Condition, + unused. + 2015-10-26 Emmanuel Briot * s-os_lib.adb (Argument_String_To_List): Remove backslashes in diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index 99d546fab9e..93fbf6cf562 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -275,9 +275,9 @@ package body Exp_Unst is -- First step, we must mark all nested subprograms that require a static -- link (activation record) because either they contain explicit uplevel - -- references (as indicated by ??? being set at this - -- point), or they make calls to other subprograms in the same nest that - -- require a static link (in which case we set this flag). + -- references (as indicated by Is_Uplevel_Referenced_Entity being set at + -- this point), or they make calls to other subprograms in the same nest + -- that require a static link (in which case we set this flag). -- This is a recursive definition, and to implement this, we have to -- build a call graph for the set of nested subprograms, and then go @@ -684,7 +684,7 @@ package body Exp_Unst is Modified : Boolean; begin - Subps.Table (1).Reachable := True; + Subps.Table (Subps_First).Reachable := True; -- We use a simple minded algorithm as follows (obviously this can -- be done more efficiently, using one of the standard algorithms @@ -822,13 +822,13 @@ package body Exp_Unst is -- Remove unreachable subprograms from Subps table. Note that we do -- this after eliminating entries from the other two tables, since - -- thos elimination steps depend on referencing the Subps table. + -- those elimination steps depend on referencing the Subps table. declare New_SI : SI_Type; begin - New_SI := 0; + New_SI := Subps_First - 1; for J in Subps_First .. Subps.Last loop declare STJ : Subp_Entry renames Subps.Table (J); diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 82c33fe6c9f..5859bcea05b 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -4560,6 +4560,11 @@ package body Ch3 is Scan; -- past RECORD TF_Semicolon; + -- This might happen because of misplaced aspect specification. + -- After discarding the misplaced aspects we can continue the + -- scan. + + Done := False; else Restore_Scan_State (Scan_State); -- to END Done := True; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index cd5f9d03bdd..912d75ecaf7 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -22932,10 +22932,6 @@ package body Sem_Prag is end if; end if; - if Class_Present (N) then - Build_Generic_Class_Condition (Spec_Id, N); - end if; - Preanalyze_Assert_Expression (Expr, Standard_Boolean); -- For a class-wide condition, a reference to a controlling formal must @@ -25727,251 +25723,6 @@ package body Sem_Prag is return False; end Appears_In; - ----------------------------------- - -- Build_Generic_Class_Condition -- - ----------------------------------- - - procedure Build_Generic_Class_Condition - (Subp : Entity_Id; - Prag : Node_Id) - is - Expr : constant Node_Id := - Get_Pragma_Arg - (First (Pragma_Argument_Associations (Prag))); - Loc : constant Source_Ptr := Sloc (Prag); - Map : constant Elist_Id := New_Elmt_List; - New_Expr : constant Node_Id := New_Copy_Tree (Expr); - New_Pred : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_External_Name (Chars (Subp), "Pre", -1)); - Typ : constant Entity_Id := Find_Dispatching_Type (Subp); - - function Replace_Formal (N : Node_Id) return Traverse_Result; - -- Replace occurrence of a formal parameter of the original expression - -- in the precondition, with the formal of the generic function created - -- for it. - - -------------------- - -- Replace_Formal -- - -------------------- - - function Replace_Formal (N : Node_Id) return Traverse_Result is - Loc : constant Source_Ptr := Sloc (N); - El : Elmt_Id; - F : Entity_Id; - New_F : Entity_Id; - - begin - if Nkind (N) = N_Identifier - and then (Nkind (Parent (N)) /= N_Parameter_Association - or else N /= Selector_Name (Parent (N))) - and then Present (Entity (N)) - and then Is_Formal (Entity (N)) - then - El := First_Elmt (Map); - while Present (El) loop - F := Node (El); - if Chars (F) = Chars (N) then - New_F := Node (Next_Elmt (El)); - - -- If this is a controlling formal, in the generic it - -- becomes a conversion to the controlling formal of the - -- operation with the class-wide precondition. If the formal - -- is an access parameter, a reference to F becomes - -- Root (New_F.all)'access. - - if Is_Controlling_Formal (F) then - if Is_Access_Type (Etype (F)) then - Rewrite (N, - Make_Attribute_Reference (Loc, - Prefix => - Unchecked_Convert_To ( - Designated_Type (Etype (F)), - Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (New_F, Loc))), - Attribute_Name => Name_Access)); - - else - Rewrite (N, - Unchecked_Convert_To - (Etype (F), New_Occurrence_Of (New_F, Sloc (N)))); - end if; - - -- Noncontrolling formals retain their original type - - else - Rewrite (N, New_Occurrence_Of (New_F, Sloc (N))); - end if; - - return OK; - end if; - - Next_Elmt (El); - Next_Elmt (El); - end loop; - - elsif Nkind (N) = N_Parameter_Association then - Set_Next_Named_Actual (N, Empty); - - elsif Nkind (N) = N_Function_Call then - Set_First_Named_Actual (N, Empty); - end if; - - return OK; - end Replace_Formal; - - procedure Map_Formals is new Traverse_Proc (Replace_Formal); - - -- Local variables - - Bod : Node_Id; - Decl : Node_Id; - F : Entity_Id; - New_F : Entity_Id; - New_Form : List_Id; - New_Typ : Entity_Id; - Par_Typ : Entity_Id; - Root_Typ : Entity_Id; - Spec : Node_Id; - - -- Start of processing for Build_Generic_Class_Pre - - begin - -- Nothing to do if previous error or expansion disabled. - - if not Expander_Active then - return; - end if; - - if Chars (Pragma_Identifier (Prag)) = Name_Postcondition then - return; - end if; - - -- Build list of controlling formals and their renamings in the new - -- generic operation. - - New_Form := New_List; - New_Typ := Empty; - - F := First_Formal (Subp); - while Present (F) loop - New_F := - Make_Defining_Identifier (Loc, New_External_Name (Chars (F), "GF")); - Set_Ekind (New_F, Ekind (F)); - Append_Elmt (F, Map); - Append_Elmt (New_F, Map); - - if Is_Controlling_Formal (F) then - Root_Typ := Etype (F); - - if Is_Access_Type (Etype (F)) then - Root_Typ := Designated_Type (Root_Typ); - New_Typ := - Make_Defining_Identifier (Loc, - Chars => - New_External_Name - (Chars (Designated_Type (Etype (F))), "GT")); - Par_Typ := - Make_Access_Definition (Loc, - Subtype_Mark => New_Occurrence_Of (New_Typ, Loc)); - else - New_Typ := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Etype (F)), "GT")); - Par_Typ := New_Occurrence_Of (New_Typ, Loc); - end if; - - Append_To (New_Form, - Make_Parameter_Specification (Loc, - Defining_Identifier => New_F, - Parameter_Type => Par_Typ)); - else - -- If formal has a class-wide type, build same attribute for new - -- formal. - - if Is_Class_Wide_Type (Etype (F)) then - Append_To (New_Form, - Make_Parameter_Specification (Loc, - Defining_Identifier => New_F, - Parameter_Type => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Etype (Etype (F)), Loc), - Attribute_Name => Name_Class))); - else - -- If it is an anonymous access type, create a similar type - -- definition. - - if Ekind (Etype (F)) = E_Anonymous_Access_Type then - Par_Typ := New_Copy_Tree (Parameter_Type (Parent (F))); - else - Par_Typ := New_Occurrence_Of (Etype (F), Loc); - end if; - - Append_To (New_Form, - Make_Parameter_Specification (Loc, - Defining_Identifier => New_F, - Parameter_Type => Par_Typ)); - end if; - end if; - - Next_Formal (F); - end loop; - - -- If no controlling formal found, pre/postcondition is incorrect. - - if No (New_Typ) then - return; - end if; - - Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => New_Pred, - Parameter_Specifications => New_Form, - Result_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)); - - Decl := - Make_Generic_Subprogram_Declaration (Loc, - Specification => Spec, - Generic_Formal_Declarations => New_List ( - Make_Formal_Type_Declaration (Loc, - Defining_Identifier => New_Typ, - Formal_Type_Definition => - Make_Formal_Derived_Type_Definition (Loc, - Subtype_Mark => New_Occurrence_Of (Root_Typ, Loc), - Private_Present => True)))); - - Preanalyze (New_Expr); - Map_Formals (New_Expr); - - Bod := - Make_Subprogram_Body (Loc, - Specification => New_Copy_Tree (Spec), - Declarations => New_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => New_Expr)))); - - -- Generic function must be analyzed after type is frozen, and will be - -- instantiated when subprogram contract for operation or any of its - -- overridings is expanded. - - Append_Freeze_Actions (Typ, New_List (Decl, Bod)); - - -- We need to convey the existence of the generic to the point at which - -- we expand the contract. We replace the expression in the pragma with - -- name of the generic function, to be instantiated when expanding the - -- contract for the subprogram or some overriding of it. See - -- Exp_ch6.Expand_Subprogram_Contract.Build_Pragma_Check_Equivalent. - -- (TBD) - - Set_Ekind (New_Pred, E_Generic_Function); - Set_Scope (New_Pred, Current_Scope); - end Build_Generic_Class_Condition; - ----------------------------- -- Check_Applicable_Policy -- ----------------------------- diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads index 7ec4ebb31e0..784578a4da0 100644 --- a/gcc/ada/sem_prag.ads +++ b/gcc/ada/sem_prag.ads @@ -231,17 +231,6 @@ package Sem_Prag is procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id); -- Perform preanalysis of pragma Test_Case - procedure Build_Generic_Class_Condition - (Subp : Entity_Id; - Prag : Node_Id); - -- AI12-113 modifies the semantics of classwide pre- and postconditions, - -- as well as type invariants, so that the expression used in an inherited - -- operation uses the actual type and is statically bound, rather than - -- using T'Class and dispatching. This new semantics is implemented by - -- building a generic function for the corresponding condition and - -- instantiating it for each descendant type. Checking the condition is - -- implemented as a call to that instantiation. - procedure Check_Applicable_Policy (N : Node_Id); -- N is either an N_Aspect or an N_Pragma node. There are two cases. If -- the name of the aspect or pragma is not one of those recognized as diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 3ecc33b9dc7..d2963f73e7c 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -8110,6 +8110,7 @@ package body Sem_Res is end if; Analyze_Dimension (N); + -- Note: No Eval processing is required for an explicit dereference, -- because such a name can never be static. @@ -8166,6 +8167,7 @@ package body Sem_Res is Indexes := Parameter_Associations (Call); Pref := Remove_Head (Indexes); Set_Expressions (N, Indexes); + Set_Generalized_Indexing (N, Empty); Set_Prefix (N, Pref); end if; -- 2.30.2