FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[multiple changes]

Browse source 
2017-01-23  Yannick Moy  <moy@adacore.com>

	* 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  <quinot@adacore.com>

	* 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  <duff@adacore.com>

	* 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
This commit is contained in:
Arnaud Charlet 2017-01-23 12:57:27 +01:00
parent d43584ca12
commit a77152ca85
12 changed files with 175 additions and 82 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

28
gcc/ada/ChangeLog
View file

@ -1,3 +1,31 @@
2017-01-23 Yannick Moy <moy@adacore.com>
* 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 <quinot@adacore.com>
* 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 <duff@adacore.com>
* 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 <kirtchev@adacore.com> 2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch5.adb, freeze.adb, par-ch4.adb, scng.adb, sem_ch13.adb, * exp_ch5.adb, freeze.adb, par-ch4.adb, scng.adb, sem_ch13.adb,

8
gcc/ada/a-ngcefu.adb
View file

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- 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); Ada.Numerics.Generic_Elementary_Functions (Real'Base);
use Elementary_Functions; use Elementary_Functions;
PI : constant := 3.14159_26535_89793_23846_26433_83279_50288_41971; PI : constant := 3.14159_26535_89793_23846_26433_83279_50288_41971;
PI_2 : constant := PI / 2.0; PI_2 : constant := PI / 2.0;
Sqrt_Two : constant := 1.41421_35623_73095_04880_16887_24209_69807_85696; 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; subtype T is Real'Base;

2
gcc/ada/exp_ch6.adb
View file

@ -6073,7 +6073,7 @@ package body Exp_Ch6 is
-- Exp_Ch9.Build_Simple_Entry_Call. The call is intra-object only if the -- 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 -- subprogram being called is in the protected body being compiled, and
-- if the protected object in the call is statically the enclosing type. -- 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. -- case this must be handled as an inter-object call.
if not In_Open_Scopes (Scop) if not In_Open_Scopes (Scop)

106
gcc/ada/exp_ch9.adb
View file

@ -688,11 +688,11 @@ package body Exp_Ch9 is
-- The name of the formal that holds the address of the parameter block -- The name of the formal that holds the address of the parameter block
-- for the call. -- for the call.
Comp : Entity_Id; Comp : Entity_Id;
Decl : Node_Id; Decl : Node_Id;
Formal : Entity_Id; Formal : Entity_Id;
New_F : Entity_Id; New_F : Entity_Id;
Renamed_Formal : Node_Id; Renamed_Formal : Node_Id;
begin begin
Formal := First_Formal (Ent); Formal := First_Formal (Ent);
@ -2117,7 +2117,7 @@ package body Exp_Ch9 is
Iface_Op_Param := Next (Iface_Op_Param); Iface_Op_Param := Next (Iface_Op_Param);
end if; end if;
Wrapper_Param := First (Wrapper_Params); Wrapper_Param := First (Wrapper_Params);
while Present (Iface_Op_Param) while Present (Iface_Op_Param)
and then Present (Wrapper_Param) and then Present (Wrapper_Param)
loop loop
@ -2599,7 +2599,7 @@ package body Exp_Ch9 is
------------------------------ ------------------------------
function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
B : Node_Id; B : Node_Id;
begin begin
if Is_Entity_Name (Bound) if Is_Entity_Name (Bound)
@ -3888,22 +3888,22 @@ package body Exp_Ch9 is
Pid : Node_Id; Pid : Node_Id;
N_Op_Spec : Node_Id) return Node_Id N_Op_Spec : Node_Id) return Node_Id
is is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Op_Spec : Node_Id; Op_Spec : Node_Id;
P_Op_Spec : Node_Id; P_Op_Spec : Node_Id;
Uactuals : List_Id; Uactuals : List_Id;
Pformal : Node_Id; Pformal : Node_Id;
Unprot_Call : Node_Id; Unprot_Call : Node_Id;
Sub_Body : Node_Id; Sub_Body : Node_Id;
Lock_Name : Node_Id; Lock_Name : Node_Id;
Lock_Stmt : Node_Id; Lock_Stmt : Node_Id;
R : Node_Id; R : Node_Id;
Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning
Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning
Stmts : List_Id; Stmts : List_Id;
Object_Parm : Node_Id; Object_Parm : Node_Id;
Exc_Safe : Boolean; Exc_Safe : Boolean;
Lock_Kind : RE_Id; Lock_Kind : RE_Id;
begin begin
Op_Spec := Specification (N); Op_Spec := Specification (N);
@ -4143,12 +4143,12 @@ package body Exp_Ch9 is
--------------------------------------------- ---------------------------------------------
procedure Build_Protected_Subprogram_Call_Cleanup procedure Build_Protected_Subprogram_Call_Cleanup
(Op_Spec : Node_Id; (Op_Spec : Node_Id;
Conc_Typ : Node_Id; Conc_Typ : Node_Id;
Loc : Source_Ptr; Loc : Source_Ptr;
Stmts : List_Id) Stmts : List_Id)
is is
Nam : Node_Id; Nam : Node_Id;
begin begin
-- If the associated protected object has entries, a protected -- If the associated protected object has entries, a protected
@ -4892,7 +4892,7 @@ package body Exp_Ch9 is
Identifier => New_Occurrence_Of (Blkent, Loc), Identifier => New_Occurrence_Of (Blkent, Loc),
Declarations => New_List ( Declarations => New_List (
-- _Chain : Activation_Chain; -- _Chain : Activation_Chain;
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Chain, Defining_Identifier => Chain,
@ -4962,7 +4962,7 @@ package body Exp_Ch9 is
Identifier => New_Occurrence_Of (Blkent, Loc), Identifier => New_Occurrence_Of (Blkent, Loc),
Declarations => New_List ( Declarations => New_List (
-- _Chain : Activation_Chain; -- _Chain : Activation_Chain;
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Chain, Defining_Identifier => Chain,
@ -8630,7 +8630,7 @@ package body Exp_Ch9 is
-- type poV (discriminants) is record -- type poV (discriminants) is record
-- _Object : aliased <kind>Protection -- _Object : aliased <kind>Protection
-- [(<entry count> [, <handler count>])]; -- [(<entry count> [, <handler count>])];
-- [entry_family : array (bounds) of Void;] -- [entry_family : array (bounds) of Void;]
-- <private data fields> -- <private data fields>
-- end record; -- end record;
@ -8938,17 +8938,17 @@ package body Exp_Ch9 is
-- Local variables -- Local variables
Body_Arr : Node_Id; Body_Arr : Node_Id;
Body_Id : Entity_Id; Body_Id : Entity_Id;
Cdecls : List_Id; Cdecls : List_Id;
Comp : Node_Id; Comp : Node_Id;
Expr : Node_Id; Expr : Node_Id;
New_Priv : Node_Id; New_Priv : Node_Id;
Obj_Def : Node_Id; Obj_Def : Node_Id;
Object_Comp : Node_Id; Object_Comp : Node_Id;
Priv : Node_Id; Priv : Node_Id;
Rec_Decl : Node_Id; Rec_Decl : Node_Id;
Sub : Node_Id; Sub : Node_Id;
-- Start of processing for Expand_N_Protected_Type_Declaration -- Start of processing for Expand_N_Protected_Type_Declaration
@ -13690,17 +13690,17 @@ package body Exp_Ch9 is
function Make_Initialize_Protection function Make_Initialize_Protection
(Protect_Rec : Entity_Id) return List_Id (Protect_Rec : Entity_Id) return List_Id
is is
Loc : constant Source_Ptr := Sloc (Protect_Rec); Loc : constant Source_Ptr := Sloc (Protect_Rec);
P_Arr : Entity_Id; P_Arr : Entity_Id;
Pdec : Node_Id; Pdec : Node_Id;
Ptyp : constant Node_Id := Ptyp : constant Node_Id :=
Corresponding_Concurrent_Type (Protect_Rec); Corresponding_Concurrent_Type (Protect_Rec);
Args : List_Id; Args : List_Id;
L : constant List_Id := New_List; L : constant List_Id := New_List;
Has_Entry : constant Boolean := Has_Entries (Ptyp); Has_Entry : constant Boolean := Has_Entries (Ptyp);
Prio_Type : Entity_Id; Prio_Type : Entity_Id;
Prio_Var : Entity_Id := Empty; Prio_Var : Entity_Id := Empty;
Restricted : constant Boolean := Restricted_Profile; Restricted : constant Boolean := Restricted_Profile;
begin begin
-- We may need two calls to properly initialize the object, one to -- We may need two calls to properly initialize the object, one to

2
gcc/ada/exp_ch9.ads
View file

@ -273,7 +273,7 @@ package Exp_Ch9 is
-- is the entity for the corresponding protected type declaration. -- is the entity for the corresponding protected type declaration.
function External_Subprogram (E : Entity_Id) return Entity_Id; 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. -- the object before invoking the internal protected subprogram body.
function Find_Master_Scope (E : Entity_Id) return Entity_Id; function Find_Master_Scope (E : Entity_Id) return Entity_Id;

7
gcc/ada/frontend.adb
View file

@ -463,9 +463,12 @@ begin
end if; end if;
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 declare
Unused : Entity_Id; Unused : Entity_Id;

8
gcc/ada/namet.adb
View file

@ -115,10 +115,12 @@ package body Namet is
procedure Append (Buf : in out Bounded_String; C : Character) is procedure Append (Buf : in out Bounded_String; C : Character) is
begin begin
if Buf.Length < Buf.Chars'Last then if Buf.Length >= Buf.Chars'Last then
Buf.Length := Buf.Length + 1; raise Program_Error;
Buf.Chars (Buf.Length) := C;
end if; end if;
Buf.Length := Buf.Length + 1;
Buf.Chars (Buf.Length) := C;
end Append; end Append;
procedure Append (Buf : in out Bounded_String; V : Nat) is procedure Append (Buf : in out Bounded_String; V : Nat) is

7
gcc/ada/namet.ads
View file

@ -31,7 +31,6 @@
with Alloc; with Alloc;
with Table; with Table;
with Hostparm; use Hostparm;
with System; use System; with System; use System;
with Types; use Types; 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 -- and the Boolean field is initialized to False, when a new Name table entry
-- is created. -- is created.
type Bounded_String (Max_Length : Natural := 4 * Max_Line_Length) is limited type Bounded_String (Max_Length : Natural := 2**12) is limited
-- The default here is intended to be an infinite value that ensures that -- It's unlikely to have names longer than this. But we don't want to make
-- we never overflow the buffer (names this long are too absurd to worry). -- it too big, because we declare these on the stack in recursive routines.
record record
Length : Natural := 0; Length : Natural := 0;
Chars : String (1 .. Max_Length); Chars : String (1 .. Max_Length);

2
gcc/ada/par-ch2.adb
View file

@ -436,7 +436,7 @@ package body Ch2 is
-- Error recovery: Cannot raise Error_Resync -- Error recovery: Cannot raise Error_Resync
procedure P_Pragmas_Opt (List : List_Id) is procedure P_Pragmas_Opt (List : List_Id) is
P : Node_Id; P : Node_Id;
begin begin
while Token = Tok_Pragma loop while Token = Tok_Pragma loop

75
gcc/ada/par_sco.adb
View file

@ -1440,7 +1440,10 @@ package body Par_SCO is
-- This routine is logically the same as Process_Decisions, except that -- This routine is logically the same as Process_Decisions, except that
-- the arguments are saved in the SD table for later processing when -- the arguments are saved in the SD table for later processing when
-- Set_Statement_Entry is called, which goes through the saved entries -- 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); procedure Process_Decisions_Defer (L : List_Id; T : Character);
pragma Inline (Process_Decisions_Defer); pragma Inline (Process_Decisions_Defer);
@ -1457,6 +1460,10 @@ package body Par_SCO is
procedure Traverse_Aspects (N : Node_Id); procedure Traverse_Aspects (N : Node_Id);
-- Helper for Traverse_One: traverse N's aspect specifications -- 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 -- -- Extend_Statement_Sequence --
------------------------------- -------------------------------
@ -1514,6 +1521,9 @@ package body Par_SCO is
To_Node := Defining_Identifier (N); To_Node := Defining_Identifier (N);
end if; end if;
when N_Subexpr =>
To_Node := N;
when others => when others =>
null; null;
end case; end case;
@ -1720,6 +1730,44 @@ package body Par_SCO is
end loop; end loop;
end Traverse_Aspects; 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 -- -- Traverse_One --
------------------ ------------------
@ -1755,9 +1803,30 @@ package body Par_SCO is
when N_Subprogram_Body_Stub when N_Subprogram_Body_Stub
| N_Subprogram_Declaration | N_Subprogram_Declaration
| N_Expression_Function
=> =>
Process_Decisions_Defer declare
(Parameter_Specifications (Specification (N)), 'X'); 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 -- Entry declaration

1
gcc/ada/scos.ads
View file

@ -152,6 +152,7 @@ package SCOs is
-- o object declaration -- o object declaration
-- r renaming declaration -- r renaming declaration
-- i generic instantiation -- i generic instantiation
-- d any other kind of declaration
-- A ACCEPT statement (from ACCEPT to end of parameter profile) -- A ACCEPT statement (from ACCEPT to end of parameter profile)
-- C CASE statement (from CASE to end of expression) -- C CASE statement (from CASE to end of expression)
-- E EXIT statement -- E EXIT statement

11
gcc/ada/sem_util.adb
View file

@ -9344,17 +9344,8 @@ package body Sem_Util is
-- The implicit case lacks all property pragmas -- The implicit case lacks all property pragmas
elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then 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 if Is_Protected_Type (Etype (Item_Id)) then
return return Protected_Object_Has_Enabled_Property;
Property = Name_Async_Readers
or else Property = Name_Async_Writers;
else else
return True; return True;
end if; end if;