mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-25 01:20:52 +08:00
Code Issues Packages Projects Releases Wiki Activity

nlists.ads, nlists.adb (In_Same_List): New function.

Browse Source 
2010-09-09  Robert Dewar  <dewar@adacore.com>

	* nlists.ads, nlists.adb (In_Same_List): New function.
	Use Node_Or_Entity_Id where appropriate.
	* par-labl.adb, sem_ch6.adb, sem_type.adb: Use In_Same_List.

2010-09-09  Robert Dewar  <dewar@adacore.com>

	* restrict.ads, restrict.adb (Check_Wide_Character_Restriction): New
	procedure.
	* sem_ch3.adb: Use Check_Wide_Character_Restriction
	(Enumeration_Type_Declaration): Check violation of No_Wide_Characters
	* sem_ch8.adb (Find_Direct_Name): Check violation of No_Wide_Characters
	(Find_Expanded_Name): Check violation of No_Wide_Characters

2010-09-09  Robert Dewar  <dewar@adacore.com>

	* par-ch5.adb: Minor reformatting.

From-SVN: r164056
This commit is contained in:
Robert Dewar 2010-09-09 09:35:11 +00:00 committed by Arnaud Charlet
parent d151d6a357
commit 30196a76d1
11 changed files with 317 additions and 202 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
gcc/ada/ChangeLog
View File

@ -1,3 +1,22 @@
2010-09-09 Robert Dewar <dewar@adacore.com>
* nlists.ads, nlists.adb (In_Same_List): New function.
Use Node_Or_Entity_Id where appropriate.
* par-labl.adb, sem_ch6.adb, sem_type.adb: Use In_Same_List.
2010-09-09 Robert Dewar <dewar@adacore.com>
* restrict.ads, restrict.adb (Check_Wide_Character_Restriction): New
procedure.
* sem_ch3.adb: Use Check_Wide_Character_Restriction
(Enumeration_Type_Declaration): Check violation of No_Wide_Characters
* sem_ch8.adb (Find_Direct_Name): Check violation of No_Wide_Characters
(Find_Expanded_Name): Check violation of No_Wide_Characters
2010-09-09 Robert Dewar <dewar@adacore.com>
* par-ch5.adb: Minor reformatting.
2010-09-09 Robert Dewar <dewar@adacore.com>
* prj-env.adb: Minor code reorganization.

243
gcc/ada/nlists.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -52,10 +52,10 @@ package body Nlists is
-- three fields:
type List_Header is record
First : Node_Id;
First : Node_Or_Entity_Id;
-- Pointer to first node in list. Empty if list is empty
Last : Node_Id;
Last : Node_Or_Entity_Id;
-- Pointer to last node in list. Empty if list is empty
Parent : Node_Id;
@ -85,16 +85,16 @@ package body Nlists is
-- list and Prev_Node is Empty at the start of a list.
package Next_Node is new Table.Table (
Table_Component_Type => Node_Id,
Table_Index_Type => Node_Id'Base,
Table_Component_Type => Node_Or_Entity_Id,
Table_Index_Type => Node_Or_Entity_Id'Base,
Table_Low_Bound => First_Node_Id,
Table_Initial => Alloc.Orig_Nodes_Initial,
Table_Increment => Alloc.Orig_Nodes_Increment,
Table_Name => "Next_Node");
package Prev_Node is new Table.Table (
Table_Component_Type => Node_Id,
Table_Index_Type => Node_Id'Base,
Table_Component_Type => Node_Or_Entity_Id,
Table_Index_Type => Node_Or_Entity_Id'Base,
Table_Low_Bound => First_Node_Id,
Table_Initial => Alloc.Orig_Nodes_Initial,
Table_Increment => Alloc.Orig_Nodes_Increment,
@ -104,23 +104,23 @@ package body Nlists is
-- Local Subprograms --
-----------------------
procedure Set_First (List : List_Id; To : Node_Id);
procedure Set_First (List : List_Id; To : Node_Or_Entity_Id);
pragma Inline (Set_First);
-- Sets First field of list header List to reference To
procedure Set_Last (List : List_Id; To : Node_Id);
procedure Set_Last (List : List_Id; To : Node_Or_Entity_Id);
pragma Inline (Set_Last);
-- Sets Last field of list header List to reference To
procedure Set_List_Link (Node : Node_Id; To : List_Id);
procedure Set_List_Link (Node : Node_Or_Entity_Id; To : List_Id);
pragma Inline (Set_List_Link);
-- Sets list link of Node to list header To
procedure Set_Next (Node : Node_Id; To : Node_Id);
procedure Set_Next (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id);
pragma Inline (Set_Next);
-- Sets the Next_Node pointer for Node to reference To
procedure Set_Prev (Node : Node_Id; To : Node_Id);
procedure Set_Prev (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id);
pragma Inline (Set_Prev);
-- Sets the Prev_Node pointer for Node to reference To
@ -128,8 +128,8 @@ package body Nlists is
-- Allocate_List_Tables --
--------------------------
procedure Allocate_List_Tables (N : Node_Id) is
Old_Last : constant Node_Id'Base := Next_Node.Last;
procedure Allocate_List_Tables (N : Node_Or_Entity_Id) is
Old_Last : constant Node_Or_Entity_Id'Base := Next_Node.Last;
begin
pragma Assert (N >= Old_Last);
@ -149,8 +149,8 @@ package body Nlists is
-- Append --
------------
procedure Append (Node : Node_Id; To : List_Id) is
L : constant Node_Id := Last (To);
procedure Append (Node : Node_Or_Entity_Id; To : List_Id) is
L : constant Node_Or_Entity_Id := Last (To);
procedure Append_Debug;
pragma Inline (Append_Debug);
@ -230,9 +230,9 @@ package body Nlists is
else
declare
L : constant Node_Id := Last (To);
F : constant Node_Id := First (List);
N : Node_Id;
L : constant Node_Or_Entity_Id := Last (To);
F : constant Node_Or_Entity_Id := First (List);
N : Node_Or_Entity_Id;
begin
pragma Debug (Append_List_Debug);
@ -272,7 +272,7 @@ package body Nlists is
-- Append_To --
---------------
procedure Append_To (To : List_Id; Node : Node_Id) is
procedure Append_To (To : List_Id; Node : Node_Or_Entity_Id) is
begin
Append (Node, To);
end Append_To;
@ -281,7 +281,7 @@ package body Nlists is
-- First --
-----------
function First (List : List_Id) return Node_Id is
function First (List : List_Id) return Node_Or_Entity_Id is
begin
if List = No_List then
return Empty;
@ -295,8 +295,8 @@ package body Nlists is
-- First_Non_Pragma --
----------------------
function First_Non_Pragma (List : List_Id) return Node_Id is
N : constant Node_Id := First (List);
function First_Non_Pragma (List : List_Id) return Node_Or_Entity_Id is
N : constant Node_Or_Entity_Id := First (List);
begin
if Nkind (N) /= N_Pragma
and then
@ -328,12 +328,23 @@ package body Nlists is
Set_Last (E, Empty);
end Initialize;
------------------
-- In_Same_List --
------------------
function In_Same_List (N1, N2 : Node_Or_Entity_Id) return Boolean is
begin
return List_Containing (N1) = List_Containing (N2);
end In_Same_List;
------------------
-- Insert_After --
------------------
procedure Insert_After (After : Node_Id; Node : Node_Id) is
procedure Insert_After
(After : Node_Or_Entity_Id;
Node : Node_Or_Entity_Id)
is
procedure Insert_After_Debug;
pragma Inline (Insert_After_Debug);
-- Output debug information if Debug_Flag_N set
@ -366,8 +377,8 @@ package body Nlists is
pragma Debug (Insert_After_Debug);
declare
Before : constant Node_Id := Next (After);
LC : constant List_Id := List_Containing (After);
Before : constant Node_Or_Entity_Id := Next (After);
LC : constant List_Id := List_Containing (After);
begin
if Present (Before) then
@ -390,8 +401,10 @@ package body Nlists is
-- Insert_Before --
-------------------
procedure Insert_Before (Before : Node_Id; Node : Node_Id) is
procedure Insert_Before
(Before : Node_Or_Entity_Id;
Node : Node_Or_Entity_Id)
is
procedure Insert_Before_Debug;
pragma Inline (Insert_Before_Debug);
-- Output debug information if Debug_Flag_N set
@ -424,8 +437,8 @@ package body Nlists is
pragma Debug (Insert_Before_Debug);
declare
After : constant Node_Id := Prev (Before);
LC : constant List_Id := List_Containing (Before);
After : constant Node_Or_Entity_Id := Prev (Before);
LC : constant List_Id := List_Containing (Before);
begin
if Present (After) then
@ -448,7 +461,7 @@ package body Nlists is
-- Insert_List_After --
-----------------------
procedure Insert_List_After (After : Node_Id; List : List_Id) is
procedure Insert_List_After (After : Node_Or_Entity_Id; List : List_Id) is
procedure Insert_List_After_Debug;
pragma Inline (Insert_List_After_Debug);
@ -479,11 +492,11 @@ package body Nlists is
else
declare
Before : constant Node_Id := Next (After);
LC : constant List_Id := List_Containing (After);
F : constant Node_Id := First (List);
L : constant Node_Id := Last (List);
N : Node_Id;
Before : constant Node_Or_Entity_Id := Next (After);
LC : constant List_Id := List_Containing (After);
F : constant Node_Or_Entity_Id := First (List);
L : constant Node_Or_Entity_Id := Last (List);
N : Node_Or_Entity_Id;
begin
pragma Debug (Insert_List_After_Debug);
@ -515,7 +528,7 @@ package body Nlists is
-- Insert_List_Before --
------------------------
procedure Insert_List_Before (Before : Node_Id; List : List_Id) is
procedure Insert_List_Before (Before : Node_Or_Entity_Id; List : List_Id) is
procedure Insert_List_Before_Debug;
pragma Inline (Insert_List_Before_Debug);
@ -546,11 +559,11 @@ package body Nlists is
else
declare
After : constant Node_Id := Prev (Before);
LC : constant List_Id := List_Containing (Before);
F : constant Node_Id := First (List);
L : constant Node_Id := Last (List);
N : Node_Id;
After : constant Node_Or_Entity_Id := Prev (Before);
LC : constant List_Id := List_Containing (Before);
F : constant Node_Or_Entity_Id := First (List);
L : constant Node_Or_Entity_Id := Last (List);
N : Node_Or_Entity_Id;
begin
pragma Debug (Insert_List_Before_Debug);
@ -591,7 +604,7 @@ package body Nlists is
-- Is_List_Member --
--------------------
function Is_List_Member (Node : Node_Id) return Boolean is
function Is_List_Member (Node : Node_Or_Entity_Id) return Boolean is
begin
return Nodes.Table (Node).In_List;
end Is_List_Member;
@ -609,7 +622,7 @@ package body Nlists is
-- Last --
----------
function Last (List : List_Id) return Node_Id is
function Last (List : List_Id) return Node_Or_Entity_Id is
begin
pragma Assert (List <= Lists.Last);
return Lists.Table (List).Last;
@ -628,8 +641,8 @@ package body Nlists is
-- Last_Non_Pragma --
---------------------
function Last_Non_Pragma (List : List_Id) return Node_Id is
N : constant Node_Id := Last (List);
function Last_Non_Pragma (List : List_Id) return Node_Or_Entity_Id is
N : constant Node_Or_Entity_Id := Last (List);
begin
if Nkind (N) /= N_Pragma then
return N;
@ -642,7 +655,7 @@ package body Nlists is
-- List_Containing --
---------------------
function List_Containing (Node : Node_Id) return List_Id is
function List_Containing (Node : Node_Or_Entity_Id) return List_Id is
begin
pragma Assert (Is_List_Member (Node));
return List_Id (Nodes.Table (Node).Link);
@ -654,7 +667,7 @@ package body Nlists is
function List_Length (List : List_Id) return Nat is
Result : Nat;
Node : Node_Id;
Node : Node_Or_Entity_Id;
begin
Result := 0;
@ -698,7 +711,7 @@ package body Nlists is
function New_Copy_List (List : List_Id) return List_Id is
NL : List_Id;
E : Node_Id;
E : Node_Or_Entity_Id;
begin
if List = No_List then
@ -723,7 +736,7 @@ package body Nlists is
function New_Copy_List_Original (List : List_Id) return List_Id is
NL : List_Id;
E : Node_Id;
E : Node_Or_Entity_Id;
begin
if List = No_List then
@ -790,7 +803,7 @@ package body Nlists is
-- list directly, rather than first building an empty list and then doing
-- the insertion, which results in some unnecessary work.
function New_List (Node : Node_Id) return List_Id is
function New_List (Node : Node_Or_Entity_Id) return List_Id is
procedure New_List_Debug;
pragma Inline (New_List_Debug);
@ -838,14 +851,21 @@ package body Nlists is
end if;
end New_List;
function New_List (Node1, Node2 : Node_Id) return List_Id is
function New_List
(Node1 : Node_Or_Entity_Id;
Node2 : Node_Or_Entity_Id) return List_Id
is
L : constant List_Id := New_List (Node1);
begin
Append (Node2, L);
return L;
end New_List;
function New_List (Node1, Node2, Node3 : Node_Id) return List_Id is
function New_List
(Node1 : Node_Or_Entity_Id;
Node2 : Node_Or_Entity_Id;
Node3 : Node_Or_Entity_Id) return List_Id
is
L : constant List_Id := New_List (Node1);
begin
Append (Node2, L);
@ -853,7 +873,12 @@ package body Nlists is
return L;
end New_List;
function New_List (Node1, Node2, Node3, Node4 : Node_Id) return List_Id is
function New_List
(Node1 : Node_Or_Entity_Id;
Node2 : Node_Or_Entity_Id;
Node3 : Node_Or_Entity_Id;
Node4 : Node_Or_Entity_Id) return List_Id
is
L : constant List_Id := New_List (Node1);
begin
Append (Node2, L);
@ -863,11 +888,11 @@ package body Nlists is
end New_List;
function New_List
(Node1 : Node_Id;
Node2 : Node_Id;
Node3 : Node_Id;
Node4 : Node_Id;
Node5 : Node_Id) return List_Id
(Node1 : Node_Or_Entity_Id;
Node2 : Node_Or_Entity_Id;
Node3 : Node_Or_Entity_Id;
Node4 : Node_Or_Entity_Id;
Node5 : Node_Or_Entity_Id) return List_Id
is
L : constant List_Id := New_List (Node1);
begin
@ -879,12 +904,12 @@ package body Nlists is
end New_List;
function New_List
(Node1 : Node_Id;
Node2 : Node_Id;
Node3 : Node_Id;
Node4 : Node_Id;
Node5 : Node_Id;
Node6 : Node_Id) return List_Id
(Node1 : Node_Or_Entity_Id;
Node2 : Node_Or_Entity_Id;
Node3 : Node_Or_Entity_Id;
Node4 : Node_Or_Entity_Id;
Node5 : Node_Or_Entity_Id;
Node6 : Node_Or_Entity_Id) return List_Id
is
L : constant List_Id := New_List (Node1);
begin
@ -900,13 +925,13 @@ package body Nlists is
-- Next --
----------
function Next (Node : Node_Id) return Node_Id is
function Next (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id is
begin
pragma Assert (Is_List_Member (Node));
return Next_Node.Table (Node);
end Next;
procedure Next (Node : in out Node_Id) is
procedure Next (Node : in out Node_Or_Entity_Id) is
begin
Node := Next (Node);
end Next;
@ -924,22 +949,22 @@ package body Nlists is
-- Next_Non_Pragma --
---------------------
function Next_Non_Pragma (Node : Node_Id) return Node_Id is
N : Node_Id;
function Next_Non_Pragma
(Node : Node_Or_Entity_Id) return Node_Or_Entity_Id
is
N : Node_Or_Entity_Id;
begin
N := Node;
loop
N := Next (N);
exit when Nkind (N) /= N_Pragma
and then
Nkind (N) /= N_Null_Statement;
exit when not Nkind_In (N, N_Pragma, N_Null_Statement);
end loop;
return N;
end Next_Non_Pragma;
procedure Next_Non_Pragma (Node : in out Node_Id) is
procedure Next_Non_Pragma (Node : in out Node_Or_Entity_Id) is
begin
Node := Next_Non_Pragma (Node);
end Next_Non_Pragma;
@ -966,10 +991,10 @@ package body Nlists is
-- p --
-------
function p (U : Union_Id) return Node_Id is
function p (U : Union_Id) return Node_Or_Entity_Id is
begin
if U in Node_Range then
return Parent (Node_Id (U));
return Parent (Node_Or_Entity_Id (U));
elsif U in List_Range then
return Parent (List_Id (U));
else
@ -981,7 +1006,7 @@ package body Nlists is
-- Parent --
------------
function Parent (List : List_Id) return Node_Id is
function Parent (List : List_Id) return Node_Or_Entity_Id is
begin
pragma Assert (List <= Lists.Last);
return Lists.Table (List).Parent;
@ -991,8 +1016,8 @@ package body Nlists is
-- Pick --
----------
function Pick (List : List_Id; Index : Pos) return Node_Id is
Elmt : Node_Id;
function Pick (List : List_Id; Index : Pos) return Node_Or_Entity_Id is
Elmt : Node_Or_Entity_Id;
begin
Elmt := First (List);
@ -1007,8 +1032,8 @@ package body Nlists is
-- Prepend --
-------------
procedure Prepend (Node : Node_Id; To : List_Id) is
F : constant Node_Id := First (To);
procedure Prepend (Node : Node_Or_Entity_Id; To : List_Id) is
F : constant Node_Or_Entity_Id := First (To);
procedure Prepend_Debug;
pragma Inline (Prepend_Debug);
@ -1088,9 +1113,9 @@ package body Nlists is
else
declare
F : constant Node_Id := First (To);
L : constant Node_Id := Last (List);
N : Node_Id;
F : constant Node_Or_Entity_Id := First (To);
L : constant Node_Or_Entity_Id := Last (List);
N : Node_Or_Entity_Id;
begin
pragma Debug (Prepend_List_Debug);
@ -1130,7 +1155,7 @@ package body Nlists is
-- Prepend_To --
----------------
procedure Prepend_To (To : List_Id; Node : Node_Id) is
procedure Prepend_To (To : List_Id; Node : Node_Or_Entity_Id) is
begin
Prepend (Node, To);
end Prepend_To;
@ -1148,13 +1173,13 @@ package body Nlists is
-- Prev --
----------
function Prev (Node : Node_Id) return Node_Id is
function Prev (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id is
begin
pragma Assert (Is_List_Member (Node));
return Prev_Node.Table (Node);
end Prev;
procedure Prev (Node : in out Node_Id) is
procedure Prev (Node : in out Node_Or_Entity_Id) is
begin
Node := Prev (Node);
end Prev;
@ -1172,8 +1197,10 @@ package body Nlists is
-- Prev_Non_Pragma --
---------------------
function Prev_Non_Pragma (Node : Node_Id) return Node_Id is
N : Node_Id;
function Prev_Non_Pragma
(Node : Node_Or_Entity_Id) return Node_Or_Entity_Id
is
N : Node_Or_Entity_Id;
begin
N := Node;
@ -1185,7 +1212,7 @@ package body Nlists is
return N;
end Prev_Non_Pragma;
procedure Prev_Non_Pragma (Node : in out Node_Id) is
procedure Prev_Non_Pragma (Node : in out Node_Or_Entity_Id) is
begin
Node := Prev_Non_Pragma (Node);
end Prev_Non_Pragma;
@ -1194,10 +1221,10 @@ package body Nlists is
-- Remove --
------------
procedure Remove (Node : Node_Id) is
Lst : constant List_Id := List_Containing (Node);
Prv : constant Node_Id := Prev (Node);
Nxt : constant Node_Id := Next (Node);
procedure Remove (Node : Node_Or_Entity_Id) is
Lst : constant List_Id := List_Containing (Node);
Prv : constant Node_Or_Entity_Id := Prev (Node);
Nxt : constant Node_Or_Entity_Id := Next (Node);
procedure Remove_Debug;
pragma Inline (Remove_Debug);
@ -1241,8 +1268,8 @@ package body Nlists is
-- Remove_Head --
-----------------
function Remove_Head (List : List_Id) return Node_Id is
Frst : constant Node_Id := First (List);
function Remove_Head (List : List_Id) return Node_Or_Entity_Id is
Frst : constant Node_Or_Entity_Id := First (List);
procedure Remove_Head_Debug;
pragma Inline (Remove_Head_Debug);
@ -1271,7 +1298,7 @@ package body Nlists is
else
declare
Nxt : constant Node_Id := Next (Frst);
Nxt : constant Node_Or_Entity_Id := Next (Frst);
begin
Set_First (List, Nxt);
@ -1293,8 +1320,10 @@ package body Nlists is
-- Remove_Next --
-----------------
function Remove_Next (Node : Node_Id) return Node_Id is
Nxt : constant Node_Id := Next (Node);
function Remove_Next
(Node : Node_Or_Entity_Id) return Node_Or_Entity_Id
is
Nxt : constant Node_Or_Entity_Id := Next (Node);
procedure Remove_Next_Debug;
pragma Inline (Remove_Next_Debug);
@ -1318,8 +1347,8 @@ package body Nlists is
begin
if Present (Nxt) then
declare
Nxt2 : constant Node_Id := Next (Nxt);
LC : constant List_Id := List_Containing (Node);
Nxt2 : constant Node_Or_Entity_Id := Next (Nxt);
LC : constant List_Id := List_Containing (Node);
begin
pragma Debug (Remove_Next_Debug);
@ -1343,7 +1372,7 @@ package body Nlists is
-- Set_First --
---------------
procedure Set_First (List : List_Id; To : Node_Id) is
procedure Set_First (List : List_Id; To : Node_Or_Entity_Id) is
begin
Lists.Table (List).First := To;
end Set_First;
@ -1352,7 +1381,7 @@ package body Nlists is
-- Set_Last --
--------------
procedure Set_Last (List : List_Id; To : Node_Id) is
procedure Set_Last (List : List_Id; To : Node_Or_Entity_Id) is
begin
Lists.Table (List).Last := To;
end Set_Last;
@ -1361,7 +1390,7 @@ package body Nlists is
-- Set_List_Link --
-------------------
procedure Set_List_Link (Node : Node_Id; To : List_Id) is
procedure Set_List_Link (Node : Node_Or_Entity_Id; To : List_Id) is
begin
Nodes.Table (Node).Link := Union_Id (To);
end Set_List_Link;
@ -1370,7 +1399,7 @@ package body Nlists is
-- Set_Next --
--------------
procedure Set_Next (Node : Node_Id; To : Node_Id) is
procedure Set_Next (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id) is
begin
Next_Node.Table (Node) := To;
end Set_Next;
@ -1379,7 +1408,7 @@ package body Nlists is
-- Set_Parent --
----------------
procedure Set_Parent (List : List_Id; Node : Node_Id) is
procedure Set_Parent (List : List_Id; Node : Node_Or_Entity_Id) is
begin
pragma Assert (List <= Lists.Last);
Lists.Table (List).Parent := Node;
@ -1389,7 +1418,7 @@ package body Nlists is
-- Set_Prev --
--------------
procedure Set_Prev (Node : Node_Id; To : Node_Id) is
procedure Set_Prev (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id) is
begin
Prev_Node.Table (Node) := To;
end Set_Prev;

129
gcc/ada/nlists.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -49,6 +49,10 @@ package Nlists is
-- Note: node lists can contain either nodes or entities (extended nodes)
-- or a mixture of nodes and extended nodes.
function In_Same_List (N1, N2 : Node_Or_Entity_Id) return Boolean;
pragma Inline (In_Same_List);
-- Equivalent to List_Containing (N1) = List_Containing (N2)
function Last_List_Id return List_Id;
pragma Inline (Last_List_Id);
-- Returns Id of last allocated list header
@ -70,33 +74,42 @@ package Nlists is
-- Used in contexts where an empty list (as opposed to an initially empty
-- list to be filled in) is required.
function New_List (Node : Node_Id) return List_Id;
function New_List
(Node : Node_Or_Entity_Id) return List_Id;
-- Build a new list initially containing the given node
function New_List (Node1, Node2 : Node_Id) return List_Id;
function New_List
(Node1 : Node_Or_Entity_Id;
Node2 : Node_Or_Entity_Id) return List_Id;
-- Build a new list initially containing the two given nodes
function New_List (Node1, Node2, Node3 : Node_Id) return List_Id;
function New_List
(Node1 : Node_Or_Entity_Id;
Node2 : Node_Or_Entity_Id;
Node3 : Node_Or_Entity_Id) return List_Id;
-- Build a new list initially containing the three given nodes
function New_List (Node1, Node2, Node3, Node4 : Node_Id) return List_Id;
-- Build a new list initially containing the four given nodes
function New_List
(Node1 : Node_Or_Entity_Id;
Node2 : Node_Or_Entity_Id;
Node3 : Node_Or_Entity_Id;
Node4 : Node_Or_Entity_Id) return List_Id;
function New_List
(Node1 : Node_Id;
Node2 : Node_Id;
Node3 : Node_Id;
Node4 : Node_Id;
Node5 : Node_Id) return List_Id;
(Node1 : Node_Or_Entity_Id;
Node2 : Node_Or_Entity_Id;
Node3 : Node_Or_Entity_Id;
Node4 : Node_Or_Entity_Id;
Node5 : Node_Or_Entity_Id) return List_Id;
-- Build a new list initially containing the five given nodes
function New_List
(Node1 : Node_Id;
Node2 : Node_Id;
Node3 : Node_Id;
Node4 : Node_Id;
Node5 : Node_Id;
Node6 : Node_Id) return List_Id;
(Node1 : Node_Or_Entity_Id;
Node2 : Node_Or_Entity_Id;
Node3 : Node_Or_Entity_Id;
Node4 : Node_Or_Entity_Id;
Node5 : Node_Or_Entity_Id;
Node6 : Node_Or_Entity_Id) return List_Id;
-- Build a new list initially containing the six given nodes
function New_Copy_List (List : List_Id) return List_Id;
@ -108,12 +121,12 @@ package Nlists is
function New_Copy_List_Original (List : List_Id) return List_Id;
-- Same as New_Copy_List but copies only nodes coming from source
function First (List : List_Id) return Node_Id;
function First (List : List_Id) return Node_Or_Entity_Id;
pragma Inline (First);
-- Obtains the first element of the given node list or, if the node list
-- has no items or is equal to No_List, then Empty is returned.
function First_Non_Pragma (List : List_Id) return Node_Id;
function First_Non_Pragma (List : List_Id) return Node_Or_Entity_Id;
-- Used when dealing with a list that can contain pragmas to skip past
-- any initial pragmas and return the first element that is not a pragma.
-- If the list is empty, or if it contains only pragmas, then Empty is
@ -122,14 +135,14 @@ package Nlists is
-- This function also skips N_Null nodes which can result from rewriting
-- unrecognized or incorrect pragmas.
function Last (List : List_Id) return Node_Id;
function Last (List : List_Id) return Node_Or_Entity_Id;
pragma Inline (Last);
-- Obtains the last element of the given node list or, if the node list
-- has no items, then Empty is returned. It is an error to call Last with
-- a Node_Id or No_List. (No_List is not considered to be the same as an
-- empty node list).
function Last_Non_Pragma (List : List_Id) return Node_Id;
function Last_Non_Pragma (List : List_Id) return Node_Or_Entity_Id;
-- Obtains the last element of a given node list that is not a pragma.
-- If the list is empty, or if it contains only pragmas, then Empty is
-- returned. It is an error to call Last_Non_Pragma with a Node_Id or
@ -141,42 +154,44 @@ package Nlists is
-- this function with No_List (No_List is not considered to be the same
-- as an empty list).
function Next (Node : Node_Id) return Node_Id;
function Next (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id;
pragma Inline (Next);
-- This function returns the next node on a node list, or Empty if Node is
-- the last element of the node list. The argument must be a member of a
-- node list.
procedure Next (Node : in out Node_Id);
procedure Next (Node : in out Node_Or_Entity_Id);
pragma Inline (Next);
-- Equivalent to Node := Next (Node);
function Next_Non_Pragma (Node : Node_Id) return Node_Id;
function Next_Non_Pragma
(Node : Node_Or_Entity_Id) return Node_Or_Entity_Id;
-- This function returns the next node on a node list, skipping past any
-- pragmas, or Empty if there is no non-pragma entry left. The argument
-- must be a member of a node list. This function also skips N_Null nodes
-- which can result from rewriting unrecognized or incorrect pragmas.
procedure Next_Non_Pragma (Node : in out Node_Id);
procedure Next_Non_Pragma (Node : in out Node_Or_Entity_Id);
pragma Inline (Next_Non_Pragma);
-- Equivalent to Node := Next_Non_Pragma (Node);
function Prev (Node : Node_Id) return Node_Id;
function Prev (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id;
pragma Inline (Prev);
-- This function returns the previous node on a node list, or Empty
-- if Node is the first element of the node list. The argument must be
-- a member of a node list. Note: the implementation does maintain back
-- pointers, so this function executes quickly in constant time.
function Pick (List : List_Id; Index : Pos) return Node_Id;
function Pick (List : List_Id; Index : Pos) return Node_Or_Entity_Id;
-- Given a list, picks out the Index'th entry (1 = first entry). The
-- caller must ensure that Index is in range.
procedure Prev (Node : in out Node_Id);
procedure Prev (Node : in out Node_Or_Entity_Id);
pragma Inline (Prev);
-- Equivalent to Node := Prev (Node);
function Prev_Non_Pragma (Node : Node_Id) return Node_Id;
function Prev_Non_Pragma
(Node : Node_Or_Entity_Id) return Node_Or_Entity_Id;
pragma Inline (Prev_Non_Pragma);
-- This function returns the previous node on a node list, skipping any
-- pragmas. If Node is the first element of the list, or if the only
@ -185,7 +200,7 @@ package Nlists is
-- does maintain back pointers, so this function executes quickly in
-- constant time.
procedure Prev_Non_Pragma (Node : in out Node_Id);
procedure Prev_Non_Pragma (Node : in out Node_Or_Entity_Id);
pragma Inline (Prev_Non_Pragma);
-- Equivalent to Node := Prev_Non_Pragma (Node);
@ -199,23 +214,23 @@ package Nlists is
-- This function determines if a given list id references a node list that
-- contains at least one item. No_List as an argument returns False.
function Is_List_Member (Node : Node_Id) return Boolean;
function Is_List_Member (Node : Node_Or_Entity_Id) return Boolean;
pragma Inline (Is_List_Member);
-- This function determines if a given node is a member of a node list.
-- It is an error for Node to be Empty, or to be a node list.
function List_Containing (Node : Node_Id) return List_Id;
function List_Containing (Node : Node_Or_Entity_Id) return List_Id;
pragma Inline (List_Containing);
-- This function provides a pointer to the node list containing Node.
-- Node must be a member of a node list.
procedure Append (Node : Node_Id; To : List_Id);
procedure Append (Node : Node_Or_Entity_Id; To : List_Id);
-- Appends Node at the end of node list To. Node must be a non-empty node
-- that is not already a member of a node list, and To must be a
-- node list. An attempt to append an error node is ignored without
-- complaint and the list is unchanged.
procedure Append_To (To : List_Id; Node : Node_Id);
procedure Append_To (To : List_Id; Node : Node_Or_Entity_Id);
pragma Inline (Append_To);
-- Like Append, but arguments are the other way round
@ -227,56 +242,72 @@ package Nlists is
pragma Inline (Append_List_To);
-- Like Append_List, but arguments are the other way round
procedure Insert_After (After : Node_Id; Node : Node_Id);
procedure Insert_After
(After : Node_Or_Entity_Id;
Node : Node_Or_Entity_Id);
-- Insert Node, which must be a non-empty node that is not already a
-- member of a node list, immediately past node After, which must be a
-- node that is currently a member of a node list. An attempt to insert
-- an error node is ignored without complaint (and the list is unchanged).
procedure Insert_List_After (After : Node_Id; List : List_Id);
procedure Insert_List_After
(After : Node_Or_Entity_Id;
List : List_Id);
-- Inserts the entire contents of node list List immediately after node
-- After, which must be a member of a node list. On return, the node list
-- List is reset to be the empty node list.
procedure Insert_Before (Before : Node_Id; Node : Node_Id);
procedure Insert_Before
(Before : Node_Or_Entity_Id;
Node : Node_Or_Entity_Id);
-- Insert Node, which must be a non-empty node that is not already a
-- member of a node list, immediately before Before, which must be a node
-- that is currently a member of a node list. An attempt to insert an
-- error node is ignored without complaint (and the list is unchanged).
procedure Insert_List_Before (Before : Node_Id; List : List_Id);
procedure Insert_List_Before
(Before : Node_Or_Entity_Id;
List : List_Id);
-- Inserts the entire contents of node list List immediately before node
-- Before, which must be a member of a node list. On return, the node list
-- List is reset to be the empty node list.
procedure Prepend (Node : Node_Id; To : List_Id);
procedure Prepend
(Node : Node_Or_Entity_Id;
To : List_Id);
-- Prepends Node at the start of node list To. Node must be a non-empty
-- node that is not already a member of a node list, and To must be a
-- node list. An attempt to prepend an error node is ignored without
-- complaint and the list is unchanged.
procedure Prepend_To (To : List_Id; Node : Node_Id);
procedure Prepend_To
(To : List_Id;
Node : Node_Or_Entity_Id);
pragma Inline (Prepend_To);
-- Like Prepend, but arguments are the other way round
procedure Prepend_List (List : List_Id; To : List_Id);
procedure Prepend_List
(List : List_Id;
To : List_Id);
-- Prepends node list List to the start of node list To. On return,
-- List is reset to be empty.
procedure Prepend_List_To (To : List_Id; List : List_Id);
procedure Prepend_List_To
(To : List_Id;
List : List_Id);
pragma Inline (Prepend_List_To);
-- Like Prepend_List, but arguments are the other way round
procedure Remove (Node : Node_Id);
procedure Remove (Node : Node_Or_Entity_Id);
-- Removes Node, which must be a node that is a member of a node list,
-- from this node list. The contents of Node are not otherwise affected.
function Remove_Head (List : List_Id) return Node_Id;
function Remove_Head (List : List_Id) return Node_Or_Entity_Id;
-- Removes the head element of a node list, and returns the node (whose
-- contents are not otherwise affected) as the result. If the node list
-- is empty, then Empty is returned.
function Remove_Next (Node : Node_Id) return Node_Id;
function Remove_Next (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id;
-- Removes the item immediately following the given node, and returns it
-- as the result. If Node is the last element of the list, then Empty is
-- returned. Node must be a member of a list. Unlike Remove, Remove_Next
@ -302,13 +333,13 @@ package Nlists is
-- Writes out internal tables to current tree file using the relevant
-- Table.Tree_Write routines.
function Parent (List : List_Id) return Node_Id;
function Parent (List : List_Id) return Node_Or_Entity_Id;
pragma Inline (Parent);
-- Node lists may have a parent in the same way as a node. The function
-- accesses the Parent value, which is either Empty when a list header
-- is first created, or the value that has been set by Set_Parent.
procedure Set_Parent (List : List_Id; Node : Node_Id);
procedure Set_Parent (List : List_Id; Node : Node_Or_Entity_Id);
pragma Inline (Set_Parent);
-- Sets the parent field of the given list to reference the given node
@ -322,7 +353,7 @@ package Nlists is
-- Tests given Id for inequality with No_List. This allows notations like
-- "if Present (Statements)" as opposed to "if Statements /= No_List".
procedure Allocate_List_Tables (N : Node_Id);
procedure Allocate_List_Tables (N : Node_Or_Entity_Id);
-- Called when nodes table is expanded to include node N. This call
-- makes sure that list structures internal to Nlists are adjusted
-- appropriately to reflect this increase in the size of the nodes table.
@ -332,7 +363,7 @@ package Nlists is
-- These functions return the addresses of the Next_Node and Prev_Node
-- tables (used in Back_End for Gigi).
function p (U : Union_Id) return Node_Id;
function p (U : Union_Id) return Node_Or_Entity_Id;
-- This function is intended for use from the debugger, it determines
-- whether U is a Node_Id or List_Id, and calls the appropriate Parent
-- function and returns the parent Node in either case. This is shorter

24
gcc/ada/par-ch5.adb
View File

@ -334,10 +334,10 @@ package body Ch5 is
when Tok_Exception =>
Test_Statement_Required;
-- If Extm not set and the exception is not to the left
-- of the expected column of the end for this sequence, then
-- we assume it belongs to the current sequence, even though
-- it is not permitted.
-- If Extm not set and the exception is not to the left of
-- the expected column of the end for this sequence, then we
-- assume it belongs to the current sequence, even though it
-- is not permitted.
if not SS_Flags.Extm and then
Start_Column >= Scope.Table (Scope.Last).Ecol
@ -350,7 +350,7 @@ package body Ch5 is
-- Always return, in the case where we scanned out handlers
-- that we did not expect, Parse_Exception_Handlers returned
-- with Token being either end or EOF, so we are OK
-- with Token being either end or EOF, so we are OK.
exit;
@ -358,8 +358,8 @@ package body Ch5 is
when Tok_Or =>
-- Terminate if Ortm set or if the or is to the left
-- of the expected column of the end for this sequence
-- Terminate if Ortm set or if the or is to the left of the
-- expected column of the end for this sequence.
if SS_Flags.Ortm
or else Start_Column < Scope.Table (Scope.Last).Ecol
@ -385,9 +385,9 @@ package body Ch5 is
exit when SS_Flags.Tatm and then Token = Tok_Abort;
-- Otherwise we treat THEN as some kind of mess where we
-- did not see the associated IF, but we pick up assuming
-- it had been there!
-- Otherwise we treat THEN as some kind of mess where we did
-- not see the associated IF, but we pick up assuming it had
-- been there!
Restore_Scan_State (Scan_State); -- to THEN
Append_To (Statement_List, P_If_Statement);
@ -397,8 +397,8 @@ package body Ch5 is
when Tok_When | Tok_Others =>
-- Terminate if Whtm set or if the WHEN is to the left
-- of the expected column of the end for this sequence
-- Terminate if Whtm set or if the WHEN is to the left of
-- the expected column of the end for this sequence.
if SS_Flags.Whtm
or else Start_Column < Scope.Table (Scope.Last).Ecol

8
gcc/ada/par-labl.adb
View File

@ -378,12 +378,10 @@ procedure Labl is
-- If the label and the goto are both in the same statement
-- list, then we've found a loop. Note that labels and goto
-- statements are always part of some list, so
-- List_Containing always makes sense.
-- statements are always part of some list, so In_Same_List
-- always makes sense.
if List_Containing (Node (N)) =
List_Containing (Node (S1))
then
if In_Same_List (Node (N), Node (S1)) then
Source := S1;
Found := True;

24
gcc/ada/restrict.adb
View File

@ -25,6 +25,7 @@
with Atree; use Atree;
with Casing; use Casing;
with Einfo; use Einfo;
with Errout; use Errout;
with Debug; use Debug;
with Fname; use Fname;
@ -396,6 +397,29 @@ package body Restrict is
end loop;
end Check_Restriction_No_Dependence;
--------------------------------------
-- Check_Wide_Character_Restriction --
--------------------------------------
procedure Check_Wide_Character_Restriction (E : Entity_Id; N : Node_Id) is
begin
if Restriction_Active (No_Wide_Characters)
and then Comes_From_Source (N)
then
declare
T : constant Entity_Id := Root_Type (E);
begin
if T = Standard_Wide_Character or else
T = Standard_Wide_String or else
T = Standard_Wide_Wide_Character or else
T = Standard_Wide_Wide_String
then
Check_Restriction (No_Wide_Characters, N);
end if;
end;
end if;
end Check_Wide_Character_Restriction;
----------------------------------------
-- Cunit_Boolean_Restrictions_Restore --
----------------------------------------

6
gcc/ada/restrict.ads
View File

@ -239,6 +239,12 @@ package Restrict is
-- mechanism (e.g. a special pragma) to handle this case, but there are
-- only six cases, and it is not worth the effort to do something general.
procedure Check_Wide_Character_Restriction (E : Entity_Id; N : Node_Id);
-- This procedure checks if the No_Wide_Character restriction is active,
-- and if so, if N Comes_From_Source, and the root type of E is one of
-- [Wide_]Wide_Character or [Wide_]Wide_String, then the restriction
-- violation is recorded, and an appropriate message given.
function Cunit_Boolean_Restrictions_Save
return Save_Cunit_Boolean_Restrictions;
-- This function saves the compilation unit restriction settings, and

28
gcc/ada/sem_ch3.adb
View File

@ -2960,13 +2960,7 @@ package body Sem_Ch3 is
-- Check No_Wide_Characters restriction
if T = Standard_Wide_Character
or else T = Standard_Wide_Wide_Character
or else Root_Type (T) = Standard_Wide_String
or else Root_Type (T) = Standard_Wide_Wide_String
then
Check_Restriction (No_Wide_Characters, Object_Definition (N));
end if;
Check_Wide_Character_Restriction (T, Object_Definition (N));
-- Indicate this is not set in source. Certainly true for constants,
-- and true for variables so far (will be reset for a variable if and
@ -13677,8 +13671,20 @@ package body Sem_Ch3 is
Generate_Definition (L);
Set_Convention (L, Convention_Intrinsic);
-- Case of character literal
if Nkind (L) = N_Defining_Character_Literal then
Set_Is_Character_Type (T, True);
-- Check violation of No_Wide_Characters
if Restriction_Active (No_Wide_Characters) then
Get_Name_String (Chars (L));
if Name_Len >= 3 and then Name_Buffer (1 .. 2) = "QW" then
Check_Restriction (No_Wide_Characters, L);
end if;
end if;
end if;
Ev := Ev + 1;
@ -14211,13 +14217,7 @@ package body Sem_Ch3 is
-- Check No_Wide_Characters restriction
if Typ = Standard_Wide_Character
or else Typ = Standard_Wide_Wide_Character
or else Typ = Standard_Wide_String
or else Typ = Standard_Wide_Wide_String
then
Check_Restriction (No_Wide_Characters, S);
end if;
Check_Wide_Character_Restriction (Typ, S);
return Typ;
end Find_Type_Of_Subtype_Indic;

16
gcc/ada/sem_ch6.adb
View File

@ -1638,9 +1638,7 @@ package body Sem_Ch6 is
if Present (Prag) then
if Present (Spec_Id) then
if List_Containing (N) =
List_Containing (Unit_Declaration_Node (Spec_Id))
then
if In_Same_List (N, Unit_Declaration_Node (Spec_Id)) then
Analyze (Prag);
end if;
@ -1649,10 +1647,12 @@ package body Sem_Ch6 is
declare
Subp : constant Entity_Id :=
Make_Defining_Identifier (Loc, Chars (Body_Id));
Make_Defining_Identifier (Loc, Chars (Body_Id));
Decl : constant Node_Id :=
Make_Subprogram_Declaration (Loc,
Specification => New_Copy_Tree (Specification (N)));
Make_Subprogram_Declaration (Loc,
Specification =>
New_Copy_Tree (Specification (N)));
begin
Set_Defining_Unit_Name (Specification (Decl), Subp);
@ -7993,9 +7993,7 @@ package body Sem_Ch6 is
("equality operator must be declared "
& "before type& is frozen", S, Typ);
elsif List_Containing (Parent (Typ))
/=
List_Containing (Decl)
elsif not In_Same_List (Parent (Typ), Decl)
and then not Is_Limited_Type (Typ)
then
Error_Msg_N

17
gcc/ada/sem_ch8.adb
View File

@ -454,8 +454,9 @@ package body Sem_Ch8 is
-- private with on E.
procedure Find_Expanded_Name (N : Node_Id);
-- Selected component is known to be expanded name. Verify legality of
-- selector given the scope denoted by prefix.
-- The input is a selected component is known to be expanded name. Verify
-- legality of selector given the scope denoted by prefix, and change node
-- N into a expanded name with a properly set Entity field.
function Find_Renamed_Entity
(N : Node_Id;
@ -4411,6 +4412,10 @@ package body Sem_Ch8 is
<<Found>> begin
-- Check violation of No_Wide_Characters restriction
Check_Wide_Character_Restriction (E, N);
-- When distribution features are available (Get_PCS_Name /=
-- Name_No_DSA), a remote access-to-subprogram type is converted
-- into a record type holding whatever information is needed to
@ -4960,6 +4965,10 @@ package body Sem_Ch8 is
Set_Etype (N, Get_Full_View (Etype (Id)));
end if;
-- Check for violation of No_Wide_Characters
Check_Wide_Character_Restriction (Id, N);
-- If the Ekind of the entity is Void, it means that all homonyms are
-- hidden from all visibility (RM 8.3(5,14-20)).
@ -7330,8 +7339,8 @@ package body Sem_Ch8 is
and then Scope (Id) /= Scope (Prev)
and then Used_As_Generic_Actual (Scope (Prev))
and then Used_As_Generic_Actual (Scope (Id))
and then List_Containing (Current_Use_Clause (Scope (Prev))) /=
List_Containing (Current_Use_Clause (Scope (Id)))
and then not In_Same_List (Current_Use_Clause (Scope (Prev)),
Current_Use_Clause (Scope (Id)))
then
Set_Is_Potentially_Use_Visible (Prev, False);
Append_Elmt (Prev, Hidden_By_Use_Clause (N));

5
gcc/ada/sem_type.adb
View File

@ -1866,6 +1866,7 @@ package body Sem_Type is
then
declare
Opnd : Node_Id;
begin
if Nkind (N) = N_Function_Call then
Opnd := First_Actual (N);
@ -1875,8 +1876,8 @@ package body Sem_Type is
if Ekind (Etype (Opnd)) = E_Anonymous_Access_Type
and then
List_Containing (Parent (Designated_Type (Etype (Opnd))))
= List_Containing (Unit_Declaration_Node (User_Subp))
In_Same_List (Parent (Designated_Type (Etype (Opnd))),
Unit_Declaration_Node (User_Subp))
then
if It2.Nam = Predef_Subp then
return It1;