+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>
* exp_ch5.adb, freeze.adb, par-ch4.adb, scng.adb, sem_ch13.adb,
-- --
-- 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- --
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;
-- 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)
-- 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);
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
------------------------------
function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
- B : Node_Id;
+ B : Node_Id;
begin
if Is_Entity_Name (Bound)
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);
---------------------------------------------
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
Identifier => New_Occurrence_Of (Blkent, Loc),
Declarations => New_List (
- -- _Chain : Activation_Chain;
+ -- _Chain : Activation_Chain;
Make_Object_Declaration (Loc,
Defining_Identifier => Chain,
Identifier => New_Occurrence_Of (Blkent, Loc),
Declarations => New_List (
- -- _Chain : Activation_Chain;
+ -- _Chain : Activation_Chain;
Make_Object_Declaration (Loc,
Defining_Identifier => Chain,
-- type poV (discriminants) is record
-- _Object : aliased <kind>Protection
-- [(<entry count> [, <handler count>])];
- -- [entry_family : array (bounds) of Void;]
+ -- [entry_family : array (bounds) of Void;]
-- <private data fields>
-- end record;
-- 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
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
-- 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;
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;
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
with Alloc;
with Table;
-with Hostparm; use Hostparm;
with System; use System;
with Types; use Types;
-- 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);
-- 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
-- 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);
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 --
-------------------------------
To_Node := Defining_Identifier (N);
end if;
+ when N_Subexpr =>
+ To_Node := N;
+
when others =>
null;
end case;
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 --
------------------
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
-- 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
-- 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;
projects / gcc.git / commitdiff