Commit 5ffe0bab by Arnaud Charlet

[multiple changes]

2011-08-03  Thomas Quinot  <quinot@adacore.com>

	* scos.adb, get_scos.adb, put_scos.adb
	New code letter for decisions: G (entry guard)
	* par_sco.adb
	(Traverse_Subprogram_Body): Rename to...
	(Traverse_Subprogram_Or_Task_Body): New subrpogram.
	(Traverse_Protected_Body): New subprogram
	(Traverse_Declarations_Or_Statements): Add traversal of task bodies,
	protected bodies and entry bodies.

2011-08-03  Yannick Moy  <moy@adacore.com>

	* einfo.adb, einfo.ads (Is_Postcondition_Proc): new flag for procedure
	entities with get/set subprograms, which is set on procedure entities
	generated by the compiler for a postcondition.
	* sem_ch6.adb (Process_PPCs): set new flag on postcondition procedures
	* alfa.adb, alfa.ads (Get_Entity_For_Decl): new function returning the
	entity for a declaration
	(Get_Unique_Entity_For_Decl): new function returning an entity which
	represents a declaration, so that matching spec and body have the same
	entity.

2011-08-03  Robert Dewar  <dewar@adacore.com>

	* a-except-2005.adb, a-cfhama.adb, a-cfhase.adb, a-cfhase.ads,
	a-cforma.adb, a-cforse.ads, a-cforse.adb: Minor reformatting

2011-08-03  Yannick Moy  <moy@adacore.com>

	* lib-xref-alfa.adb (Detect_And_Add_ALFA_Scope): make the subprogram
	library-level because retriction No_Implicit_Dynamic_Code in the
	front-end prevents its definition as a local subprogram
	(Traverse_Compilation_Unit): extract new procedure from Add_ALFA_File,
	for reuse in other contexts
	(Traverse_Declarations_Or_Statements,
	Traverse_Handled_Statement_Sequence, Traverse_Package_Body,
	Traverse_Package_Declaration, Traverse_Subprogram_Body): make all these
	procedures take a callback parameter to be called on all declarations
	* lib-xref.ads
	(Traverse_All_Compilation_Units): new generic function to traverse a
	compilation unit and call a callback parameter on all declarations

From-SVN: r177284
parent f9ad6b62
2011-08-03 Thomas Quinot <quinot@adacore.com>
* scos.adb, get_scos.adb, put_scos.adb
New code letter for decisions: G (entry guard)
* par_sco.adb
(Traverse_Subprogram_Body): Rename to...
(Traverse_Subprogram_Or_Task_Body): New subrpogram.
(Traverse_Protected_Body): New subprogram
(Traverse_Declarations_Or_Statements): Add traversal of task bodies,
protected bodies and entry bodies.
2011-08-03 Yannick Moy <moy@adacore.com>
* einfo.adb, einfo.ads (Is_Postcondition_Proc): new flag for procedure
entities with get/set subprograms, which is set on procedure entities
generated by the compiler for a postcondition.
* sem_ch6.adb (Process_PPCs): set new flag on postcondition procedures
* alfa.adb, alfa.ads (Get_Entity_For_Decl): new function returning the
entity for a declaration
(Get_Unique_Entity_For_Decl): new function returning an entity which
represents a declaration, so that matching spec and body have the same
entity.
2011-08-03 Robert Dewar <dewar@adacore.com>
* a-except-2005.adb, a-cfhama.adb, a-cfhase.adb, a-cfhase.ads,
a-cforma.adb, a-cforse.ads, a-cforse.adb: Minor reformatting
2011-08-03 Yannick Moy <moy@adacore.com>
* lib-xref-alfa.adb (Detect_And_Add_ALFA_Scope): make the subprogram
library-level because retriction No_Implicit_Dynamic_Code in the
front-end prevents its definition as a local subprogram
(Traverse_Compilation_Unit): extract new procedure from Add_ALFA_File,
for reuse in other contexts
(Traverse_Declarations_Or_Statements,
Traverse_Handled_Statement_Sequence, Traverse_Package_Body,
Traverse_Package_Declaration, Traverse_Subprogram_Body): make all these
procedures take a callback parameter to be called on all declarations
* lib-xref.ads
(Traverse_All_Compilation_Units): new generic function to traverse a
compilation unit and call a callback parameter on all declarations
2011-08-03 Javier Miranda <miranda@adacore.com>
* sem_prag.adb (Process_Interface_Name): Allow duplicated export names
......
......@@ -68,6 +68,7 @@ package Ada.Containers.Formal_Hashed_Sets is
pragma Pure;
type Set (Capacity : Count_Type; Modulus : Hash_Type) is tagged private;
-- why is this commented out ???
-- pragma Preelaborable_Initialization (Set);
type Cursor is private;
......
......@@ -67,6 +67,7 @@ package Ada.Containers.Formal_Ordered_Sets is
function Equivalent_Elements (Left, Right : Element_Type) return Boolean;
type Set (Capacity : Count_Type) is tagged private;
-- why is this commented out ???
-- pragma Preelaborable_Initialization (Set);
type Cursor is private;
......@@ -276,7 +277,7 @@ private
new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type);
type Set (Capacity : Count_Type) is
new Tree_Types.Tree_Type (Capacity) with null record;
new Tree_Types.Tree_Type (Capacity) with null record;
use Red_Black_Trees;
use Ada.Streams;
......
......@@ -895,9 +895,11 @@ package body Ada.Exceptions is
Prefix : constant String := "adjust/finalize raised ";
Orig_Msg : constant String := Exception_Message (X);
Orig_Prefix_Length : constant Natural :=
Integer'Min (Prefix'Length, Orig_Msg'Length);
Integer'Min
(Prefix'Length, Orig_Msg'Length);
Orig_Prefix : String renames Orig_Msg
(Orig_Msg'First .. Orig_Msg'First + Orig_Prefix_Length - 1);
(Orig_Msg'First ..
Orig_Msg'First + Orig_Prefix_Length - 1);
begin
-- Message already has the proper prefix, just re-raise
......
......@@ -23,8 +23,10 @@
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Output; use Output;
with Put_ALFA;
with Sinfo; use Sinfo;
package body ALFA is
......@@ -153,6 +155,74 @@ package body ALFA is
ALFA_Xref_Table.Init;
end Initialize_ALFA_Tables;
-------------------------
-- Get_Entity_For_Decl --
-------------------------
function Get_Entity_For_Decl (N : Node_Id) return Entity_Id is
E : Entity_Id := Empty;
begin
case Nkind (N) is
when N_Subprogram_Declaration |
N_Subprogram_Body |
N_Package_Declaration =>
E := Defining_Unit_Name (Specification (N));
when N_Package_Body =>
E := Defining_Unit_Name (N);
when N_Object_Declaration =>
E := Defining_Identifier (N);
when others =>
null;
end case;
if Nkind (E) = N_Defining_Program_Unit_Name then
E := Defining_Identifier (E);
end if;
return E;
end Get_Entity_For_Decl;
--------------------------------
-- Get_Unique_Entity_For_Decl --
--------------------------------
function Get_Unique_Entity_For_Decl (N : Node_Id) return Entity_Id is
E : Entity_Id := Empty;
begin
case Nkind (N) is
when N_Subprogram_Declaration |
N_Package_Declaration =>
E := Defining_Unit_Name (Specification (N));
when N_Package_Body =>
E := Corresponding_Spec (N);
when N_Subprogram_Body =>
if Acts_As_Spec (N) then
E := Defining_Unit_Name (Specification (N));
else
E := Corresponding_Spec (N);
end if;
when N_Object_Declaration =>
E := Defining_Identifier (N);
when others =>
null;
end case;
if Nkind (E) = N_Defining_Program_Unit_Name then
E := Defining_Identifier (E);
end if;
return E;
end Get_Unique_Entity_For_Decl;
-----------
-- palfa --
-----------
......
......@@ -323,6 +323,13 @@ package ALFA is
procedure Initialize_ALFA_Tables;
-- Reset tables for a new compilation
function Get_Entity_For_Decl (N : Node_Id) return Entity_Id;
-- Return the entity for declaration N
function Get_Unique_Entity_For_Decl (N : Node_Id) return Entity_Id;
-- Return the entity which represents declaration N, so that matching
-- declaration and body have the same entity.
procedure palfa;
-- Debugging procedure to output contents of ALFA binary tables in the
-- format in which they appear in an ALI file.
......
......@@ -521,7 +521,7 @@ package body Einfo is
-- Body_Is_In_ALFA Flag251
-- Is_Processed_Transient Flag252
-- (unused) Flag253
-- Is_Postcondition_Proc Flag253
-- (unused) Flag254
-----------------------
......@@ -1976,6 +1976,12 @@ package body Einfo is
return Flag138 (Id);
end Is_Packed_Array_Type;
function Is_Postcondition_Proc (Id : E) return B is
begin
pragma Assert (Ekind (Id) = E_Procedure);
return Flag253 (Id);
end Is_Postcondition_Proc;
function Is_Potentially_Use_Visible (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
......@@ -4494,6 +4500,12 @@ package body Einfo is
Set_Flag138 (Id, V);
end Set_Is_Packed_Array_Type;
procedure Set_Is_Postcondition_Proc (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Procedure);
Set_Flag253 (Id, V);
end Set_Is_Postcondition_Proc;
procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
......@@ -7563,6 +7575,7 @@ package body Einfo is
W ("Is_Package_Body_Entity", Flag160 (Id));
W ("Is_Packed", Flag51 (Id));
W ("Is_Packed_Array_Type", Flag138 (Id));
W ("Is_Postcondition_Proc", Flag253 (Id));
W ("Is_Potentially_Use_Visible", Flag9 (Id));
W ("Is_Preelaborated", Flag59 (Id));
W ("Is_Primitive", Flag218 (Id));
......
......@@ -2563,6 +2563,10 @@ package Einfo is
-- an entity, then the Original_Array_Type field of this entity points
-- to the original array type for which this is the packed array type.
-- Is_Postcondition_Proc (Flag253)
-- Present in procedures. Set if entity is a procedure generated by the
-- compiler for a postcondition.
-- Is_Potentially_Use_Visible (Flag9)
-- Present in all entities. Set if entity is potentially use visible,
-- i.e. it is defined in a package that appears in a currently active
......@@ -5521,6 +5525,7 @@ package Einfo is
-- Is_Intrinsic_Subprogram (Flag64)
-- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
-- Is_Null_Init_Proc (Flag178)
-- Is_Postcondition_Proc (Flag253) (non-generic case only)
-- Is_Primitive (Flag218)
-- Is_Primitive_Wrapper (Flag195) (non-generic case only)
-- Is_Private_Descendant (Flag53)
......@@ -6213,6 +6218,7 @@ package Einfo is
function Is_Package_Body_Entity (Id : E) return B;
function Is_Packed (Id : E) return B;
function Is_Packed_Array_Type (Id : E) return B;
function Is_Postcondition_Proc (Id : E) return B;
function Is_Potentially_Use_Visible (Id : E) return B;
function Is_Preelaborated (Id : E) return B;
function Is_Primitive (Id : E) return B;
......@@ -6807,6 +6813,7 @@ package Einfo is
procedure Set_Is_Package_Body_Entity (Id : E; V : B := True);
procedure Set_Is_Packed (Id : E; V : B := True);
procedure Set_Is_Packed_Array_Type (Id : E; V : B := True);
procedure Set_Is_Postcondition_Proc (Id : E; V : B := True);
procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True);
procedure Set_Is_Preelaborated (Id : E; V : B := True);
procedure Set_Is_Primitive (Id : E; V : B := True);
......@@ -7535,6 +7542,7 @@ package Einfo is
pragma Inline (Is_Overloadable);
pragma Inline (Is_Packed);
pragma Inline (Is_Packed_Array_Type);
pragma Inline (Is_Postcondition_Proc);
pragma Inline (Is_Potentially_Use_Visible);
pragma Inline (Is_Preelaborated);
pragma Inline (Is_Primitive);
......@@ -7946,6 +7954,7 @@ package Einfo is
pragma Inline (Set_Is_Package_Body_Entity);
pragma Inline (Set_Is_Packed);
pragma Inline (Set_Is_Packed_Array_Type);
pragma Inline (Set_Is_Postcondition_Proc);
pragma Inline (Set_Is_Potentially_Use_Visible);
pragma Inline (Set_Is_Preelaborated);
pragma Inline (Set_Is_Primitive);
......
......@@ -307,7 +307,7 @@ begin
-- Decision entry
when 'I' | 'E' | 'P' | 'W' | 'X' =>
when 'I' | 'E' | 'G' | 'P' | 'W' | 'X' =>
Dtyp := C;
Skip_Spaces;
......
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2009-2010, Free Software Foundation, Inc. --
-- Copyright (C) 2009-2011, 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- --
......@@ -126,7 +126,8 @@ package body Par_SCO is
procedure Traverse_Handled_Statement_Sequence (N : Node_Id);
procedure Traverse_Package_Body (N : Node_Id);
procedure Traverse_Package_Declaration (N : Node_Id);
procedure Traverse_Subprogram_Body (N : Node_Id);
procedure Traverse_Protected_Body (N : Node_Id);
procedure Traverse_Subprogram_Or_Task_Body (N : Node_Id);
procedure Traverse_Subprogram_Declaration (N : Node_Id);
-- Traverse the corresponding construct, generating SCO table entries
......@@ -439,6 +440,9 @@ package body Par_SCO is
-------------------
procedure Output_Header (T : Character) is
Loc : Source_Ptr := No_Location;
-- Node whose sloc is used for the decision
begin
case T is
when 'I' | 'E' | 'W' =>
......@@ -446,55 +450,47 @@ package body Par_SCO is
-- For IF, EXIT, WHILE, the token SLOC can be found from
-- the SLOC of the parent of the expression.
Set_Table_Entry
(C1 => T,
C2 => ' ',
From => Sloc (Parent (N)),
To => No_Location,
Last => False);
Loc := Sloc (Parent (N));
when 'P' =>
when 'G' | 'P' =>
-- For entry, the token sloc is from the N_Entry_Body.
-- For PRAGMA, we must get the location from the pragma node.
-- Argument N is the pragma argument, and we have to go up two
-- levels (through the pragma argument association) to get to
-- the pragma node itself.
declare
Loc : constant Source_Ptr := Sloc (Parent (Parent (N)));
begin
Set_Table_Entry
(C1 => 'P',
C2 => 'd',
From => Loc,
To => No_Location,
Last => False);
-- For pragmas we also must make an entry in the hash table
-- for later access by Set_SCO_Pragma_Enabled. We set the
-- pragma as disabled above, the call will change C2 to 'e'
-- to enable the pragma header entry.
Condition_Pragma_Hash_Table.Set (Loc, SCO_Table.Last);
end;
Loc := Sloc (Parent (Parent (N)));
when 'X' =>
-- For an expression, no Sloc
Set_Table_Entry
(C1 => 'X',
C2 => ' ',
From => No_Location,
To => No_Location,
Last => False);
null;
-- No other possibilities
when others =>
raise Program_Error;
end case;
Set_Table_Entry
(C1 => T,
C2 => ' ',
From => Loc,
To => No_Location,
Last => False);
if T = 'P' then
-- For pragmas we also must make an entry in the hash table
-- for later access by Set_SCO_Pragma_Enabled. We set the
-- pragma as disabled now, the call will change C2 to 'e'
-- to enable the pragma header entry.
SCO_Table.Table (SCO_Table.Last).C2 := 'd';
Condition_Pragma_Hash_Table.Set (Loc, SCO_Table.Last);
end if;
end Output_Header;
------------------------------
......@@ -773,30 +769,34 @@ package body Par_SCO is
-- Traverse the unit
if Nkind (Lu) = N_Subprogram_Body then
Traverse_Subprogram_Body (Lu);
case Nkind (Lu) is
when N_Protected_Body =>
Traverse_Protected_Body (Lu);
elsif Nkind (Lu) = N_Subprogram_Declaration then
Traverse_Subprogram_Declaration (Lu);
when N_Subprogram_Body | N_Task_Body =>
Traverse_Subprogram_Or_Task_Body (Lu);
elsif Nkind (Lu) = N_Package_Declaration then
Traverse_Package_Declaration (Lu);
when N_Subprogram_Declaration =>
Traverse_Subprogram_Declaration (Lu);
elsif Nkind (Lu) = N_Package_Body then
Traverse_Package_Body (Lu);
when N_Package_Declaration =>
Traverse_Package_Declaration (Lu);
elsif Nkind (Lu) = N_Generic_Package_Declaration then
Traverse_Generic_Package_Declaration (Lu);
when N_Package_Body =>
Traverse_Package_Body (Lu);
elsif Nkind (Lu) in N_Generic_Instantiation then
Traverse_Generic_Instantiation (Lu);
when N_Generic_Package_Declaration =>
Traverse_Generic_Package_Declaration (Lu);
-- All other cases of compilation units (e.g. renamings), generate
-- no SCO information.
when N_Generic_Instantiation =>
Traverse_Generic_Instantiation (Lu);
else
null;
end if;
when others =>
-- All other cases of compilation units (e.g. renamings), generate
-- no SCO information.
null;
end case;
-- Make entry for new unit in unit tables, we will fill in the file
-- name and dependency numbers later.
......@@ -1144,11 +1144,31 @@ package body Par_SCO is
(Parameter_Specifications (Specification (N)), 'X');
Set_Statement_Entry;
-- Subprogram_Body
-- Task or subprogram body
when N_Task_Body | N_Subprogram_Body =>
Set_Statement_Entry;
Traverse_Subprogram_Or_Task_Body (N);
-- Entry body
when N_Entry_Body =>
declare
Cond : constant Node_Id :=
Condition (Entry_Body_Formal_Part (N));
begin
Set_Statement_Entry;
if Present (Cond) then
Process_Decisions_Defer (Cond, 'G');
end if;
Traverse_Subprogram_Or_Task_Body (N);
end;
-- Protected body
when N_Subprogram_Body =>
when N_Protected_Body =>
Set_Statement_Entry;
Traverse_Subprogram_Body (N);
Traverse_Protected_Body (N);
-- Exit statement, which is an exit statement in the SCO sense,
-- so it is included in the current statement sequence, but
......@@ -1485,15 +1505,24 @@ package body Par_SCO is
Traverse_Declarations_Or_Statements (Private_Declarations (Spec));
end Traverse_Package_Declaration;
------------------------------
-- Traverse_Subprogram_Body --
------------------------------
-----------------------------
-- Traverse_Protected_Body --
-----------------------------
procedure Traverse_Protected_Body (N : Node_Id) is
begin
Traverse_Declarations_Or_Statements (Declarations (N));
end Traverse_Protected_Body;
--------------------------------------
-- Traverse_Subprogram_Or_Task_Body --
--------------------------------------
procedure Traverse_Subprogram_Body (N : Node_Id) is
procedure Traverse_Subprogram_Or_Task_Body (N : Node_Id) is
begin
Traverse_Declarations_Or_Statements (Declarations (N));
Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
end Traverse_Subprogram_Body;
end Traverse_Subprogram_Or_Task_Body;
-------------------------------------
-- Traverse_Subprogram_Declaration --
......
......@@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P U T _ S C O S --
-- P U T _ S C O S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2009, Free Software Foundation, Inc. --
-- Copyright (C) 2009-2011, 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- --
......@@ -142,7 +142,7 @@ begin
-- Decision
when 'I' | 'E' | 'P' | 'W' | 'X' =>
when 'I' | 'E' | 'G' | 'P' | 'W' | 'X' =>
Start := Start + 1;
-- For disabled pragma, skip decision output
......
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2009-2010, Free Software Foundation, Inc. --
-- Copyright (C) 2009-2011, 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- --
......@@ -228,12 +228,13 @@ package SCOs is
-- I decision in IF statement or conditional expression
-- E decision in EXIT WHEN statement
-- G decision in entry guard
-- P decision in pragma Assert/Check/Pre_Condition/Post_Condition
-- W decision in WHILE iteration scheme
-- X decision appearing in some other expression context
-- For I, E, P, W, sloc is the source location of the IF, EXIT, PRAGMA or
-- WHILE token.
-- For I, E, G, P, W, sloc is the source location of the IF, EXIT,
-- ENTRY, PRAGMA or WHILE token, respectively
-- For X, sloc is omitted
......
......@@ -9550,6 +9550,9 @@ package body Sem_Ch6 is
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Plist)));
Set_Ekind (Post_Proc, E_Procedure);
Set_Is_Postcondition_Proc (Post_Proc);
-- If this is a procedure, set the Postcondition_Proc attribute on
-- the proper defining entity for the subprogram.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment