From a77152ca855e6009a38ee011043465d60ed8f5c2 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 23 Jan 2017 12:57:27 +0100 Subject: [PATCH] [multiple changes] 2017-01-23 Yannick Moy * frontend.adb (Frontend): Do not load runtime unit for GNATprove when parsing failed. * exp_ch9.adb: minor removal of extra whitespace * exp_ch6.adb: minor typo in comment * sem_util.adb: Code cleanup. * exp_ch9.ads, par-ch2.adb: minor style fixes in whitespace and comment * a-ngcefu.adb: minor style fix in whitespace 2017-01-23 Thomas Quinot * scos.ads: Document usage of 'd' as default SCO kind for declarations. * par_sco.adb (Traverse_Declarations_Or_Statements. Traverse_Degenerate_Subprogram): New supporting routine for expression functions and null procedures. (Traverse_Declarations_Or_Statements.Traverse_One): Add N_Expression_Function to the subprogram case; add required support for null procedures and expression functions. 2017-01-23 Bob Duff * namet.ads (Bounded_String): Decrease the size of type Bounded_String to avoid running out of stack space. * namet.ads (Append): Don't ignore buffer overflow; raise Program_Error instead. From-SVN: r244789 --- gcc/ada/ChangeLog | 28 ++++++++++++ gcc/ada/a-ngcefu.adb | 8 ++-- gcc/ada/exp_ch6.adb | 2 +- gcc/ada/exp_ch9.adb | 106 +++++++++++++++++++++---------------------- gcc/ada/exp_ch9.ads | 2 +- gcc/ada/frontend.adb | 7 ++- gcc/ada/namet.adb | 8 ++-- gcc/ada/namet.ads | 7 ++- gcc/ada/par-ch2.adb | 2 +- gcc/ada/par_sco.adb | 75 ++++++++++++++++++++++++++++-- gcc/ada/scos.ads | 1 + gcc/ada/sem_util.adb | 11 +---- 12 files changed, 175 insertions(+), 82 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c28e5af6b9b..df86a3a6717 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,31 @@ +2017-01-23 Yannick Moy + + * frontend.adb (Frontend): Do not load runtime + unit for GNATprove when parsing failed. + * exp_ch9.adb: minor removal of extra whitespace + * exp_ch6.adb: minor typo in comment + * sem_util.adb: Code cleanup. + * exp_ch9.ads, par-ch2.adb: minor style fixes in whitespace and comment + * a-ngcefu.adb: minor style fix in whitespace + +2017-01-23 Thomas Quinot + + * scos.ads: Document usage of 'd' as default SCO kind for + declarations. + * par_sco.adb (Traverse_Declarations_Or_Statements. + Traverse_Degenerate_Subprogram): New supporting routine for expression + functions and null procedures. + (Traverse_Declarations_Or_Statements.Traverse_One): Add + N_Expression_Function to the subprogram case; add required + support for null procedures and expression functions. + +2017-01-23 Bob Duff + + * namet.ads (Bounded_String): Decrease the size of type + Bounded_String to avoid running out of stack space. + * namet.ads (Append): Don't ignore buffer overflow; raise + Program_Error instead. + 2017-01-23 Hristian Kirtchev * exp_ch5.adb, freeze.adb, par-ch4.adb, scng.adb, sem_ch13.adb, diff --git a/gcc/ada/a-ngcefu.adb b/gcc/ada/a-ngcefu.adb index abe7e3dac6d..b241f2718a0 100644 --- a/gcc/ada/a-ngcefu.adb +++ b/gcc/ada/a-ngcefu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -37,10 +37,10 @@ package body Ada.Numerics.Generic_Complex_Elementary_Functions is Ada.Numerics.Generic_Elementary_Functions (Real'Base); use Elementary_Functions; - PI : constant := 3.14159_26535_89793_23846_26433_83279_50288_41971; - PI_2 : constant := PI / 2.0; + PI : constant := 3.14159_26535_89793_23846_26433_83279_50288_41971; + PI_2 : constant := PI / 2.0; Sqrt_Two : constant := 1.41421_35623_73095_04880_16887_24209_69807_85696; - Log_Two : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755; + Log_Two : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755; subtype T is Real'Base; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index e76927b383c..a6579c28e39 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6073,7 +6073,7 @@ package body Exp_Ch6 is -- Exp_Ch9.Build_Simple_Entry_Call. The call is intra-object only if the -- subprogram being called is in the protected body being compiled, and -- if the protected object in the call is statically the enclosing type. - -- The object may be an component of some other data structure, in which + -- The object may be a component of some other data structure, in which -- case this must be handled as an inter-object call. if not In_Open_Scopes (Scop) diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 55fcbe6f0d4..38f36f9de6b 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -688,11 +688,11 @@ package body Exp_Ch9 is -- The name of the formal that holds the address of the parameter block -- for the call. - Comp : Entity_Id; - Decl : Node_Id; - Formal : Entity_Id; - New_F : Entity_Id; - Renamed_Formal : Node_Id; + Comp : Entity_Id; + Decl : Node_Id; + Formal : Entity_Id; + New_F : Entity_Id; + Renamed_Formal : Node_Id; begin Formal := First_Formal (Ent); @@ -2117,7 +2117,7 @@ package body Exp_Ch9 is Iface_Op_Param := Next (Iface_Op_Param); end if; - Wrapper_Param := First (Wrapper_Params); + Wrapper_Param := First (Wrapper_Params); while Present (Iface_Op_Param) and then Present (Wrapper_Param) loop @@ -2599,7 +2599,7 @@ package body Exp_Ch9 is ------------------------------ function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is - B : Node_Id; + B : Node_Id; begin if Is_Entity_Name (Bound) @@ -3888,22 +3888,22 @@ package body Exp_Ch9 is Pid : Node_Id; N_Op_Spec : Node_Id) return Node_Id is - Loc : constant Source_Ptr := Sloc (N); - Op_Spec : Node_Id; - P_Op_Spec : Node_Id; - Uactuals : List_Id; - Pformal : Node_Id; - Unprot_Call : Node_Id; - Sub_Body : Node_Id; - Lock_Name : Node_Id; - Lock_Stmt : Node_Id; - R : Node_Id; - Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning - Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning - Stmts : List_Id; - Object_Parm : Node_Id; - Exc_Safe : Boolean; - Lock_Kind : RE_Id; + Loc : constant Source_Ptr := Sloc (N); + Op_Spec : Node_Id; + P_Op_Spec : Node_Id; + Uactuals : List_Id; + Pformal : Node_Id; + Unprot_Call : Node_Id; + Sub_Body : Node_Id; + Lock_Name : Node_Id; + Lock_Stmt : Node_Id; + R : Node_Id; + Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning + Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning + Stmts : List_Id; + Object_Parm : Node_Id; + Exc_Safe : Boolean; + Lock_Kind : RE_Id; begin Op_Spec := Specification (N); @@ -4143,12 +4143,12 @@ package body Exp_Ch9 is --------------------------------------------- procedure Build_Protected_Subprogram_Call_Cleanup - (Op_Spec : Node_Id; - Conc_Typ : Node_Id; - Loc : Source_Ptr; - Stmts : List_Id) + (Op_Spec : Node_Id; + Conc_Typ : Node_Id; + Loc : Source_Ptr; + Stmts : List_Id) is - Nam : Node_Id; + Nam : Node_Id; begin -- If the associated protected object has entries, a protected @@ -4892,7 +4892,7 @@ package body Exp_Ch9 is Identifier => New_Occurrence_Of (Blkent, Loc), Declarations => New_List ( - -- _Chain : Activation_Chain; + -- _Chain : Activation_Chain; Make_Object_Declaration (Loc, Defining_Identifier => Chain, @@ -4962,7 +4962,7 @@ package body Exp_Ch9 is Identifier => New_Occurrence_Of (Blkent, Loc), Declarations => New_List ( - -- _Chain : Activation_Chain; + -- _Chain : Activation_Chain; Make_Object_Declaration (Loc, Defining_Identifier => Chain, @@ -8630,7 +8630,7 @@ package body Exp_Ch9 is -- type poV (discriminants) is record -- _Object : aliased Protection -- [( [, ])]; - -- [entry_family : array (bounds) of Void;] + -- [entry_family : array (bounds) of Void;] -- -- end record; @@ -8938,17 +8938,17 @@ package body Exp_Ch9 is -- Local variables - Body_Arr : Node_Id; - Body_Id : Entity_Id; - Cdecls : List_Id; - Comp : Node_Id; - Expr : Node_Id; - New_Priv : Node_Id; - Obj_Def : Node_Id; - Object_Comp : Node_Id; - Priv : Node_Id; - Rec_Decl : Node_Id; - Sub : Node_Id; + Body_Arr : Node_Id; + Body_Id : Entity_Id; + Cdecls : List_Id; + Comp : Node_Id; + Expr : Node_Id; + New_Priv : Node_Id; + Obj_Def : Node_Id; + Object_Comp : Node_Id; + Priv : Node_Id; + Rec_Decl : Node_Id; + Sub : Node_Id; -- Start of processing for Expand_N_Protected_Type_Declaration @@ -13690,17 +13690,17 @@ package body Exp_Ch9 is function Make_Initialize_Protection (Protect_Rec : Entity_Id) return List_Id is - Loc : constant Source_Ptr := Sloc (Protect_Rec); - P_Arr : Entity_Id; - Pdec : Node_Id; - Ptyp : constant Node_Id := - Corresponding_Concurrent_Type (Protect_Rec); - Args : List_Id; - L : constant List_Id := New_List; - Has_Entry : constant Boolean := Has_Entries (Ptyp); - Prio_Type : Entity_Id; - Prio_Var : Entity_Id := Empty; - Restricted : constant Boolean := Restricted_Profile; + Loc : constant Source_Ptr := Sloc (Protect_Rec); + P_Arr : Entity_Id; + Pdec : Node_Id; + Ptyp : constant Node_Id := + Corresponding_Concurrent_Type (Protect_Rec); + Args : List_Id; + L : constant List_Id := New_List; + Has_Entry : constant Boolean := Has_Entries (Ptyp); + Prio_Type : Entity_Id; + Prio_Var : Entity_Id := Empty; + Restricted : constant Boolean := Restricted_Profile; begin -- We may need two calls to properly initialize the object, one to diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads index a677324b2fe..60fc056132c 100644 --- a/gcc/ada/exp_ch9.ads +++ b/gcc/ada/exp_ch9.ads @@ -273,7 +273,7 @@ package Exp_Ch9 is -- is the entity for the corresponding protected type declaration. function External_Subprogram (E : Entity_Id) return Entity_Id; - -- return the external version of a protected operation, which locks + -- Return the external version of a protected operation, which locks -- the object before invoking the internal protected subprogram body. function Find_Master_Scope (E : Entity_Id) return Entity_Id; diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index dd79db5cb79..42d91d6c4ad 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -463,9 +463,12 @@ begin end if; end if; - -- In GNATprove mode, force the loading of a few RTE units + -- In GNATprove mode, force the loading of a few RTE units. This step is + -- skipped if we had a fatal error during parsing. - if GNATprove_Mode then + if GNATprove_Mode + and then Fatal_Error (Main_Unit) /= Error_Detected + then declare Unused : Entity_Id; diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index 1fdc37ca731..5bea77d93e2 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -115,10 +115,12 @@ package body Namet is procedure Append (Buf : in out Bounded_String; C : Character) is begin - if Buf.Length < Buf.Chars'Last then - Buf.Length := Buf.Length + 1; - Buf.Chars (Buf.Length) := C; + if Buf.Length >= Buf.Chars'Last then + raise Program_Error; end if; + + Buf.Length := Buf.Length + 1; + Buf.Chars (Buf.Length) := C; end Append; procedure Append (Buf : in out Bounded_String; V : Nat) is diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index 9c25b4f7854..8c1f124991b 100644 --- a/gcc/ada/namet.ads +++ b/gcc/ada/namet.ads @@ -31,7 +31,6 @@ with Alloc; with Table; -with Hostparm; use Hostparm; with System; use System; with Types; use Types; @@ -149,9 +148,9 @@ package Namet is -- and the Boolean field is initialized to False, when a new Name table entry -- is created. - type Bounded_String (Max_Length : Natural := 4 * Max_Line_Length) is limited - -- The default here is intended to be an infinite value that ensures that - -- we never overflow the buffer (names this long are too absurd to worry). + type Bounded_String (Max_Length : Natural := 2**12) is limited + -- It's unlikely to have names longer than this. But we don't want to make + -- it too big, because we declare these on the stack in recursive routines. record Length : Natural := 0; Chars : String (1 .. Max_Length); diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb index 2fff6c73a24..16e3be731c1 100644 --- a/gcc/ada/par-ch2.adb +++ b/gcc/ada/par-ch2.adb @@ -436,7 +436,7 @@ package body Ch2 is -- Error recovery: Cannot raise Error_Resync procedure P_Pragmas_Opt (List : List_Id) is - P : Node_Id; + P : Node_Id; begin while Token = Tok_Pragma loop diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index 4815cf0ba41..ceed72c8c10 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -1440,7 +1440,10 @@ package body Par_SCO is -- This routine is logically the same as Process_Decisions, except that -- the arguments are saved in the SD table for later processing when -- Set_Statement_Entry is called, which goes through the saved entries - -- making the corresponding calls to Process_Decision. + -- making the corresponding calls to Process_Decision. Note: the + -- enclosing statement must have already been added to the current + -- statement sequence, so that nested decisions are properly + -- identified as such. procedure Process_Decisions_Defer (L : List_Id; T : Character); pragma Inline (Process_Decisions_Defer); @@ -1457,6 +1460,10 @@ package body Par_SCO is procedure Traverse_Aspects (N : Node_Id); -- Helper for Traverse_One: traverse N's aspect specifications + procedure Traverse_Degenerate_Subprogram (N : Node_Id); + -- Common code to handle null procedures and expression functions. + -- Emit a SCO of the given Kind and N outside of the dominance flow. + ------------------------------- -- Extend_Statement_Sequence -- ------------------------------- @@ -1514,6 +1521,9 @@ package body Par_SCO is To_Node := Defining_Identifier (N); end if; + when N_Subexpr => + To_Node := N; + when others => null; end case; @@ -1720,6 +1730,44 @@ package body Par_SCO is end loop; end Traverse_Aspects; + ------------------------------------ + -- Traverse_Degenerate_Subprogram -- + ------------------------------------ + + procedure Traverse_Degenerate_Subprogram (N : Node_Id) is + begin + -- Complete current sequence of statements + + Set_Statement_Entry; + + declare + Saved_Dominant : constant Dominant_Info := Current_Dominant; + -- Save last statement in current sequence as dominant + + begin + -- Output statement SCO for degenerate subprogram body + -- (null statement or freestanding expression) outside of + -- the dominance chain. + + Current_Dominant := No_Dominant; + Extend_Statement_Sequence (N, Typ => ' '); + + -- For the case of an expression-function, collect decisions + -- embedded in the expression now. + + if Nkind (N) in N_Subexpr then + Process_Decisions_Defer (N, 'X'); + end if; + Set_Statement_Entry; + + -- Restore current dominant information designating last + -- statement in previous sequence (i.e. make the dominance + -- chain skip over the degenerate body). + + Current_Dominant := Saved_Dominant; + end; + end Traverse_Degenerate_Subprogram; + ------------------ -- Traverse_One -- ------------------ @@ -1755,9 +1803,30 @@ package body Par_SCO is when N_Subprogram_Body_Stub | N_Subprogram_Declaration + | N_Expression_Function => - Process_Decisions_Defer - (Parameter_Specifications (Specification (N)), 'X'); + declare + Spec : constant Node_Id := Specification (N); + begin + Process_Decisions_Defer + (Parameter_Specifications (Spec), 'X'); + + -- Case of a null procedure: generate a NULL statement SCO + + if Nkind (N) = N_Subprogram_Declaration + and then Nkind (Spec) = N_Procedure_Specification + and then Null_Present (Spec) + then + Traverse_Degenerate_Subprogram (N); + + -- Case of an expression function: generate a statement + -- SCO for the expression (and then decision SCOs for any + -- nested decisions). + + elsif Nkind (N) = N_Expression_Function then + Traverse_Degenerate_Subprogram (Expression (N)); + end if; + end; -- Entry declaration diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads index 61f6efe2397..412a45b2583 100644 --- a/gcc/ada/scos.ads +++ b/gcc/ada/scos.ads @@ -152,6 +152,7 @@ package SCOs is -- o object declaration -- r renaming declaration -- i generic instantiation + -- d any other kind of declaration -- A ACCEPT statement (from ACCEPT to end of parameter profile) -- C CASE statement (from CASE to end of expression) -- E EXIT statement diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 3f714429052..752a69b16e4 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -9344,17 +9344,8 @@ package body Sem_Util is -- The implicit case lacks all property pragmas elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then - - -- A variable of a protected type only has the properties - -- Async_Readers and Async_Writers. It cannot have Part_Of - -- components (only protected objects can), hence it cannot - -- inherit their properties Effective_Reads and Effective_Writes. - -- (SPARK RM 7.1.2(16)) - if Is_Protected_Type (Etype (Item_Id)) then - return - Property = Name_Async_Readers - or else Property = Name_Async_Writers; + return Protected_Object_Has_Enabled_Property; else return True; end if; -- 2.30.2