git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

[multiple changes] 

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

	* exp_ch5.adb, sem_ch3.adb, a-cihama.adb, a-cihama.ads, exp_ch7.adb,
	sem_ch5.adb, a-ciorse.adb, a-ciorse.ads, sem_ch12.adb, a-cidlli.adb,
	a-cidlli.ads, sem_util.adb, sem_res.adb, gnat1drv.adb, a-except.adb,
	a-except.ads, a-except-2005.ads, sem_ch4.adb, exp_disp.adb,
	exp_aggr.adb, sem_ch13.adb, par-ch3.adb: Minor reformatting.

2011-08-29  Tristan Gingold  <gingold@adacore.com>

	* s-auxdec-vms-alpha.adb: Add comments, remove some HT before labels.

2011-08-29  Vadim Godunko  <godunko@adacore.com>

	* s-parint.ads: Minor comment clarification.

2011-08-29  Vincent Celier  <celier@adacore.com>

	* prj.adb (Initialize): Make sure that new reserved words after Ada 95
	may be used as identifiers.

2011-08-29  Ed Schonberg  <schonberg@adacore.com>

	* a-coinho.ads: Minor reformating.

From-SVN: r178239
This commit is contained in:
Arnaud Charlet 2011-08-29 16:12:57 +02:00
parent 3a613a3621
commit 833eaa8a3d
27 changed files with 340 additions and 282 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
gcc/ada/ChangeLog
View File

@ -1,3 +1,28 @@
2011-08-29 Robert Dewar <dewar@adacore.com>
* exp_ch5.adb, sem_ch3.adb, a-cihama.adb, a-cihama.ads, exp_ch7.adb,
sem_ch5.adb, a-ciorse.adb, a-ciorse.ads, sem_ch12.adb, a-cidlli.adb,
a-cidlli.ads, sem_util.adb, sem_res.adb, gnat1drv.adb, a-except.adb,
a-except.ads, a-except-2005.ads, sem_ch4.adb, exp_disp.adb,
exp_aggr.adb, sem_ch13.adb, par-ch3.adb: Minor reformatting.
2011-08-29 Tristan Gingold <gingold@adacore.com>
* s-auxdec-vms-alpha.adb: Add comments, remove some HT before labels.
2011-08-29 Vadim Godunko <godunko@adacore.com>
* s-parint.ads: Minor comment clarification.
2011-08-29 Vincent Celier <celier@adacore.com>
* prj.adb (Initialize): Make sure that new reserved words after Ada 95
may be used as identifiers.
2011-08-29 Ed Schonberg <schonberg@adacore.com>
* a-coinho.ads: Minor reformating.
2011-08-29 Ed Schonberg <schonberg@adacore.com>
* exp_ch5.adb (Expand_Iterator_Loop): Handle properly a loop over a

31
gcc/ada/a-cidlli.adb
View File

@ -39,14 +39,19 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
List_Iterator_Interfaces.Reversible_Iterator with record
Container : List_Access;
Node : Node_Access;
end record;
end record;
overriding function First (Object : Iterator) return Cursor;
overriding function Last (Object : Iterator) return Cursor;
overriding function Next (Object : Iterator; Position : Cursor)
return Cursor;
overriding function Previous (Object : Iterator; Position : Cursor)
return Cursor;
overriding function First (Object : Iterator) return Cursor;
overriding function Last (Object : Iterator) return Cursor;
overriding function Next
(Object : Iterator;
Position : Cursor) return Cursor;
overriding function Previous
(Object : Iterator;
Position : Cursor) return Cursor;
-----------------------
-- Local Subprograms --
@ -838,16 +843,19 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
B := B - 1;
end Iterate;
function Iterate (Container : List)
return List_Iterator_Interfaces.Reversible_Iterator'class
function Iterate
(Container : List)
return List_Iterator_Interfaces.Reversible_Iterator'class
is
It : constant Iterator := (Container'Unchecked_Access, Container.First);
begin
return It;
end Iterate;
function Iterate (Container : List; Start : Cursor)
return List_Iterator_Interfaces.Reversible_Iterator'class
function Iterate
(Container : List;
Start : Cursor)
return List_Iterator_Interfaces.Reversible_Iterator'class
is
It : constant Iterator := (Container'Unchecked_Access, Start.Node);
begin
@ -1008,7 +1016,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
begin
if Position.Node = Position.Container.First then
return No_Element;
else
return (Object.Container, Position.Node.Prev);
end if;

24
gcc/ada/a-cidlli.ads
View File

@ -32,7 +32,8 @@
------------------------------------------------------------------------------
with Ada.Iterator_Interfaces;
with Ada.Streams; use Ada.Streams;
with Ada.Streams; use Ada.Streams;
private with Ada.Finalization;
generic
@ -45,8 +46,7 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is
pragma Preelaborate;
pragma Remote_Types;
type List is tagged private
with
type List is tagged private with
Constant_Indexing => Constant_Reference,
Variable_Indexing => Reference,
Default_Iterator => Iterate,
@ -60,6 +60,7 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is
Empty_List : constant List;
No_Element : constant Cursor;
function Has_Element (Position : Cursor) return Boolean;
package List_Iterator_Interfaces is new
@ -189,10 +190,13 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is
(Container : List;
Process : not null access procedure (Position : Cursor));
function Iterate (Container : List)
function Iterate
(Container : List)
return List_Iterator_Interfaces.Reversible_Iterator'class;
function Iterate (Container : List; Start : Cursor)
function Iterate
(Container : List;
Start : Cursor)
return List_Iterator_Interfaces.Reversible_Iterator'class;
type Constant_Reference_Type
@ -230,12 +234,14 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is
for Reference_Type'Read use Read;
function Constant_Reference
(Container : List; Position : Cursor) -- SHOULD BE ALIASED
return Constant_Reference_Type;
(Container : List;
Position : Cursor) -- SHOULD BE ALIASED ???
return Constant_Reference_Type;
function Reference
(Container : List; Position : Cursor) -- SHOULD BE ALIASED
return Reference_Type;
(Container : List;
Position : Cursor) -- SHOULD BE ALIASED ???
return Reference_Type;
generic
with function "<" (Left, Right : Element_Type) return Boolean is <>;

30
gcc/ada/a-cihama.adb
View File

@ -45,13 +45,15 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
type Iterator is new
Map_Iterator_Interfaces.Forward_Iterator with record
Container : Map_Access;
Node : Node_Access;
end record;
Container : Map_Access;
Node : Node_Access;
end record;
overriding function First (Object : Iterator) return Cursor;
overriding function Next (Object : Iterator; Position : Cursor)
return Cursor;
overriding function Next
(Object : Iterator;
Position : Cursor) return Cursor;
-----------------------
-- Local Subprograms --
@ -414,9 +416,9 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
begin
if N = null then
return No_Element;
else
return Cursor'(Object.Container.all'Unchecked_Access, N);
end if;
return Cursor'(Object.Container.all'Unchecked_Access, N);
end First;
----------
@ -426,6 +428,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
procedure Free (X : in out Node_Access) is
procedure Deallocate is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
begin
if X = null then
return;
@ -743,7 +746,6 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
begin
if Position.Node = null then
return No_Element;
else
return (Object.Container, Next (Position).Node);
end if;
@ -874,15 +876,19 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
-- Reference --
---------------
function Constant_Reference (Container : Map; Key : Key_Type)
return Constant_Reference_Type is
function Constant_Reference
(Container : Map;
Key : Key_Type) return Constant_Reference_Type
is
begin
return (Element =>
Container.Find (Key).Node.Element.all'Unrestricted_Access);
end Constant_Reference;
function Reference (Container : Map; Key : Key_Type)
return Reference_Type is
function Reference
(Container : Map;
Key : Key_Type) return Reference_Type
is
begin
return (Element =>
Container.Find (Key).Node.Element.all'Unrestricted_Access);

10
gcc/ada/a-cihama.ads
View File

@ -48,8 +48,7 @@ package Ada.Containers.Indefinite_Hashed_Maps is
pragma Preelaborate;
pragma Remote_Types;
type Map is tagged private
with
type Map is tagged private with
Constant_Indexing => Constant_Reference,
Variable_Indexing => Reference,
Default_Iterator => Iterate,
@ -60,7 +59,7 @@ package Ada.Containers.Indefinite_Hashed_Maps is
type Cursor is private;
pragma Preelaborable_Initialization (Cursor);
Empty_Map : constant Map;
Empty_Map : constant Map;
-- Map objects declared without an initialization expression are
-- initialized to the value Empty_Map.
@ -286,8 +285,9 @@ package Ada.Containers.Indefinite_Hashed_Maps is
for Reference_Type'Read use Read;
function Constant_Reference
(Container : Map; Key : Key_Type) -- SHOULD BE ALIASED
return Constant_Reference_Type;
(Container : Map;
Key : Key_Type) -- SHOULD BE ALIASED ???
return Constant_Reference_Type;
function Reference (Container : Map; Key : Key_Type)
return Reference_Type;

68
gcc/ada/a-ciorse.adb
View File

@ -42,16 +42,21 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
type Iterator is new
Ordered_Set_Iterator_Interfaces.Reversible_Iterator with record
Container : access constant Set;
Node : Node_Access;
end record;
Container : access constant Set;
Node : Node_Access;
end record;
overriding function First (Object : Iterator) return Cursor;
overriding function Last (Object : Iterator) return Cursor;
overriding function Next (Object : Iterator; Position : Cursor)
return Cursor;
overriding function Previous (Object : Iterator; Position : Cursor)
return Cursor;
overriding function Last (Object : Iterator) return Cursor;
overriding function Next
(Object : Iterator;
Position : Cursor) return Cursor;
overriding function Previous
(Object : Iterator;
Position : Cursor) return Cursor;
-----------------------
-- Local Subprograms --
@ -582,7 +587,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
function First (Object : Iterator) return Cursor is
begin
return Cursor'(
Object.Container.all'Unrestricted_Access, Object.Container.Tree.First);
Object.Container.all'Unrestricted_Access, Object.Container.Tree.First);
end First;
-------------------
@ -593,9 +598,9 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
begin
if Container.Tree.First = null then
raise Constraint_Error with "set is empty";
else
return Container.Tree.First.Element.all;
end if;
return Container.Tree.First.Element.all;
end First_Element;
-----------
@ -605,13 +610,12 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
function Floor (Container : Set; Item : Element_Type) return Cursor is
Node : constant Node_Access :=
Element_Keys.Floor (Container.Tree, Item);
begin
if Node = null then
return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Node);
end if;
return Cursor'(Container'Unrestricted_Access, Node);
end Floor;
----------
@ -1209,8 +1213,9 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
B := B - 1;
end Iterate;
function Iterate (Container : Set)
return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class
function Iterate
(Container : Set)
return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class
is
It : constant Iterator :=
(Container'Unchecked_Access, Container.Tree.First);
@ -1218,8 +1223,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
return It;
end Iterate;
function Iterate (Container : Set; Start : Cursor)
return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class
function Iterate
(Container : Set;
Start : Cursor)
return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class
is
It : constant Iterator := (Container'Unchecked_Access, Start.Node);
begin
@ -1234,19 +1241,20 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
begin
if Container.Tree.Last = null then
return No_Element;
else
return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
end if;
return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
end Last;
function Last (Object : Iterator) return Cursor is
begin
if Object.Container.Tree.Last = null then
return No_Element;
else
return Cursor'(
Object.Container.all'Unrestricted_Access,
Object.Container.Tree.Last);
end if;
return Cursor'(
Object.Container.all'Unrestricted_Access, Object.Container.Tree.Last);
end Last;
------------------
@ -1257,9 +1265,9 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
begin
if Container.Tree.Last = null then
raise Constraint_Error with "set is empty";
else
return Container.Tree.Last.Element.all;
end if;
return Container.Tree.Last.Element.all;
end Last_Element;
----------
@ -1327,8 +1335,9 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
end;
end Next;
function Next (Object : Iterator; Position : Cursor)
return Cursor
function Next
(Object : Iterator;
Position : Cursor) return Cursor
is
pragma Unreferenced (Object);
begin
@ -1388,8 +1397,9 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
end;
end Previous;
function Previous (Object : Iterator; Position : Cursor)
return Cursor
function Previous
(Object : Iterator;
Position : Cursor) return Cursor
is
pragma Unreferenced (Object);
begin

28
gcc/ada/a-ciorse.ads
View File

@ -48,12 +48,11 @@ package Ada.Containers.Indefinite_Ordered_Sets is
function Equivalent_Elements (Left, Right : Element_Type) return Boolean;
type Set is tagged private
with
Constant_Indexing => Constant_Reference,
Variable_Indexing => Reference,
Default_Iterator => Iterate,
Iterator_Element => Element_Type;
type Set is tagged private with
Constant_Indexing => Constant_Reference,
Variable_Indexing => Reference,
Default_Iterator => Iterate,
Iterator_Element => Element_Type;
pragma Preelaborable_Initialization (Set);
@ -63,15 +62,15 @@ package Ada.Containers.Indefinite_Ordered_Sets is
Empty_Set : constant Set;
No_Element : constant Cursor;
function Has_Element (Position : Cursor) return Boolean;
package Ordered_Set_Iterator_Interfaces is new
Ada.Iterator_Interfaces (Cursor, Has_Element);
type Constant_Reference_Type
(Element : not null access constant Element_Type) is
private
with
(Element : not null access constant Element_Type) is
private with
Implicit_Dereference => Element;
procedure Read
@ -87,8 +86,8 @@ package Ada.Containers.Indefinite_Ordered_Sets is
for Constant_Reference_Type'Write use Write;
function Constant_Reference
(Container : Set; Position : Cursor)
return Constant_Reference_Type;
(Container : Set;
Position : Cursor) return Constant_Reference_Type;
type Reference_Type (Element : not null access Element_Type) is private
with
@ -241,10 +240,13 @@ package Ada.Containers.Indefinite_Ordered_Sets is
(Container : Set;
Process : not null access procedure (Position : Cursor));
function Iterate (Container : Set)
function Iterate
(Container : Set)
return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class;
function Iterate (Container : Set; Start : Cursor)
function Iterate
(Container : Set;
Start : Cursor)
return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class;
generic

2
gcc/ada/a-coinho.ads
View File

@ -2,7 +2,7 @@
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- A D A . C O N T A I N E R S . B O U N D E D _ V E C T O R S --
-- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S --
-- --
-- S p e c --
-- --

2
gcc/ada/a-except-2005.ads
View File

@ -251,7 +251,7 @@ private
-- is already deferred.
function Triggered_By_Abort return Boolean;
-- Determine whether the current exception (if exists) is an instance of
-- Determine whether the current exception (if it exists) is an instance of
-- Standard'Abort_Signal.
-----------------------

1
gcc/ada/a-except.adb
View File

@ -1276,7 +1276,6 @@ package body Ada.Exceptions is
function Triggered_By_Abort return Boolean is
Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all;
begin
return Ex /= null
and then Exception_Identity (Ex.all) = Standard'Abort_Signal'Identity;

2
gcc/ada/a-except.ads
View File

@ -222,7 +222,7 @@ private
-- abort is already deferred.
function Triggered_By_Abort return Boolean;
-- Determine whether the current exception (if exists) is an instance of
-- Determine whether the current exception (if it exists) is an instance of
-- Standard'Abort_Signal.
-----------------------

3
gcc/ada/exp_aggr.adb
View File

@ -5215,9 +5215,10 @@ package body Exp_Aggr is
-------------------------
function Top_Level_Aggregate (N : Node_Id) return Node_Id is
Aggr : Node_Id := N;
Aggr : Node_Id;
begin
Aggr := N;
while Present (Parent (Aggr))
and then Nkind_In (Parent (Aggr), N_Component_Association,
N_Aggregate)

51
gcc/ada/exp_ch5.adb
View File

@ -2858,7 +2858,7 @@ package body Exp_Ch5 is
New_Reference_To (Iterator, Loc)))));
-- for Index in Array loop
--
-- This case utilizes the already given iterator name
else
@ -2869,7 +2869,7 @@ package body Exp_Ch5 is
-- for Iterator in [reverse] Container'Range loop
-- Element : Component_Type renames Container (Iterator);
-- -- for the "of" form
--
-- <original loop statements>
-- end loop;
@ -2952,10 +2952,12 @@ package body Exp_Ch5 is
if Of_Present (I_Spec) then
declare
Default_Iter : constant Entity_Id :=
Entity (
Find_Aspect
(Etype (Container), Aspect_Default_Iterator));
Default_Iter : constant Entity_Id :=
Entity
(Find_Aspect
(Etype (Container),
Aspect_Default_Iterator));
Container_Arg : Node_Id;
Ent : Entity_Id;
@ -2975,7 +2977,7 @@ package body Exp_Ch5 is
-- inherited from the scope of the parent.
if Base_Type (Etype (Container)) =
Base_Type (Etype (First_Formal (Default_Iter)))
Base_Type (Etype (First_Formal (Default_Iter)))
then
Container_Arg := New_Copy_Tree (Container);
@ -2985,8 +2987,8 @@ package body Exp_Ch5 is
Container_Arg :=
Make_Type_Conversion (Loc,
Subtype_Mark =>
New_Occurrence_Of (
Etype (First_Formal (Default_Iter)), Loc),
New_Occurrence_Of
(Etype (First_Formal (Default_Iter)), Loc),
Expression => New_Copy_Tree (Container));
end if;
@ -3015,11 +3017,11 @@ package body Exp_Ch5 is
Decl :=
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Id,
Subtype_Mark =>
Subtype_Mark =>
New_Reference_To (Element_Type, Loc),
Name =>
Name =>
Make_Indexed_Component (Loc,
Prefix => Make_Selected_Component (Loc,
Prefix => Make_Selected_Component (Loc,
Prefix => New_Reference_To (Pack, Loc),
Selector_Name =>
Make_Identifier (Loc, Chars => Name_Element)),
@ -3042,7 +3044,7 @@ package body Exp_Ch5 is
Stats := New_List (
Make_Block_Statement (Loc,
Declarations => New_List (Decl),
Declarations => New_List (Decl),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stats)));
@ -3078,10 +3080,12 @@ package body Exp_Ch5 is
-- For both iterator forms, add a call to the step operation to
-- advance the cursor. Generate:
--
-- Cursor := Iterator.Next (Cursor);
-- Cursor := Iterator.Next (Cursor);
-- or else
-- Cursor := Next (Cursor);
-- Cursor := Next (Cursor);
declare
Rhs : Node_Id;
@ -3089,9 +3093,9 @@ package body Exp_Ch5 is
begin
Rhs :=
Make_Function_Call (Loc,
Name =>
Name =>
Make_Selected_Component (Loc,
Prefix => New_Reference_To (Iterator, Loc),
Prefix => New_Reference_To (Iterator, Loc),
Selector_Name => Make_Identifier (Loc, Name_Step)),
Parameter_Associations => New_List (
New_Reference_To (Cursor, Loc)));
@ -3113,7 +3117,7 @@ package body Exp_Ch5 is
Make_Iteration_Scheme (Loc,
Condition =>
Make_Function_Call (Loc,
Name =>
Name =>
Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Pack, Loc),
Selector_Name =>
@ -3127,7 +3131,7 @@ package body Exp_Ch5 is
-- Create the declarations for Iterator and cursor and insert then
-- before the source loop. Generate:
--
-- I : Iterator_Type := Iterate (Container);
-- C : Pack.Cursor_Type := Container.[First | Last];
@ -3146,12 +3150,11 @@ package body Exp_Ch5 is
Decl2 :=
Make_Object_Declaration (Loc,
Defining_Identifier => Cursor,
Object_Definition =>
Object_Definition =>
New_Occurrence_Of (Etype (Cursor), Loc),
Expression =>
Expression =>
Make_Selected_Component (Loc,
Prefix => New_Reference_To (Iterator, Loc),
Prefix => New_Reference_To (Iterator, Loc),
Selector_Name =>
Make_Identifier (Loc, Name_Init)));

4
gcc/ada/exp_ch7.adb
View File

@ -3062,7 +3062,7 @@ package body Exp_Ch7 is
if RTE_Available (RE_Raise_From_Controlled_Operation) then
Stmt :=
Make_Procedure_Call_Statement (Loc,
Name =>
Name =>
New_Reference_To
(RTE (RE_Raise_From_Controlled_Operation), Loc),
Parameter_Associations =>
@ -3087,7 +3087,7 @@ package body Exp_Ch7 is
return
Make_If_Statement (Loc,
Condition =>
Condition =>
Make_And_Then (Loc,
Left_Opnd => New_Reference_To (Raised_Id, Loc),
Right_Opnd =>

56
gcc/ada/exp_disp.adb
View File

@ -2117,14 +2117,12 @@ package body Exp_Disp is
if Is_Interface (Typ) then
return
Make_Subprogram_Body (Loc,
Specification =>
Make_Disp_Asynchronous_Select_Spec (Typ),
Declarations =>
New_List,
Specification => Make_Disp_Asynchronous_Select_Spec (Typ),
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
New_List (Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uF),
Name => Make_Identifier (Loc, Name_uF),
Expression => New_Reference_To (Standard_False, Loc)))));
end if;
@ -2270,7 +2268,7 @@ package body Exp_Disp is
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uF),
Name => Make_Identifier (Loc, Name_uF),
Expression => New_Reference_To (Standard_False, Loc)));
else
@ -2313,16 +2311,15 @@ package body Exp_Disp is
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uF),
Name => Make_Identifier (Loc, Name_uF),
Expression => New_Reference_To (Standard_False, Loc)));
end if;
return
Make_Subprogram_Body (Loc,
Specification =>
Specification =>
Make_Disp_Asynchronous_Select_Spec (Typ),
Declarations =>
Decls,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts));
end Make_Disp_Asynchronous_Select_Body;
@ -2490,7 +2487,7 @@ package body Exp_Disp is
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
New_List (Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uF),
Name => Make_Identifier (Loc, Name_uF),
Expression => New_Reference_To (Standard_False, Loc)))));
end if;
@ -2696,20 +2693,19 @@ package body Exp_Disp is
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uF),
Name => Make_Identifier (Loc, Name_uF),
Expression => New_Reference_To (Standard_False, Loc)));
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uC),
Name => Make_Identifier (Loc, Name_uC),
Expression => New_Reference_To (RTE (RE_POK_Function), Loc)));
end if;
return
Make_Subprogram_Body (Loc,
Specification =>
Specification =>
Make_Disp_Conditional_Select_Spec (Typ),
Declarations =>
Decls,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts));
end Make_Disp_Conditional_Select_Body;
@ -3346,9 +3342,10 @@ package body Exp_Disp is
New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
New_List (Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uF),
Expression => New_Reference_To (Standard_False, Loc)))));
New_List (
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uF),
Expression => New_Reference_To (Standard_False, Loc)))));
end if;
if Is_Concurrent_Record_Type (Typ) then
@ -3362,10 +3359,8 @@ package body Exp_Disp is
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uI),
Object_Definition =>
New_Reference_To (Standard_Integer, Loc)));
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI),
Object_Definition => New_Reference_To (Standard_Integer, Loc)));
-- Generate:
-- C := Get_Prim_Op_Kind (tag! (<type>VP), S);
@ -3394,7 +3389,7 @@ package body Exp_Disp is
else
Tag_Node :=
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Typ, Loc),
Prefix => New_Reference_To (Typ, Loc),
Attribute_Name => Name_Tag);
end if;
@ -3403,8 +3398,7 @@ package body Exp_Disp is
Name => Make_Identifier (Loc, Name_uI),
Expression =>
Make_Function_Call (Loc,
Name =>
New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
Name => New_Reference_To (RTE (RE_Get_Entry_Index), Loc),
Parameter_Associations =>
New_List (
Tag_Node,
@ -3531,20 +3525,18 @@ package body Exp_Disp is
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uF),
Name => Make_Identifier (Loc, Name_uF),
Expression => New_Reference_To (Standard_False, Loc)));
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => Make_Identifier (Loc, Name_uC),
Name => Make_Identifier (Loc, Name_uC),
Expression => New_Reference_To (RTE (RE_POK_Function), Loc)));
end if;
return
Make_Subprogram_Body (Loc,
Specification =>
Make_Disp_Timed_Select_Spec (Typ),
Declarations =>
Decls,
Specification => Make_Disp_Timed_Select_Spec (Typ),
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts));
end Make_Disp_Timed_Select_Body;

2
gcc/ada/gnat1drv.adb
View File

@ -479,7 +479,7 @@ procedure Gnat1drv is
-- We would prefer to suppress the expansion of tagged types and
-- dispatching calls, so that one day GNATprove can handle them
-- directly. Unfortunately, this is causing problems on H513-015, so
-- keep this expansion for the time being.
-- keep this expansion for the time being. ???
Tagged_Type_Expansion := True;
end if;

6
gcc/ada/par-ch3.adb
View File

@ -2672,7 +2672,8 @@ package body Ch3 is
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
-- AI95-406 makes "aliased" legal (and useless) in this context.
-- AI95-406 makes "aliased" legal (and useless) in this context so
-- followintg code which used to be needed is commented out.
-- if Aliased_Present then
-- Error_Msg_SP ("ALIASED not allowed here");
@ -3449,7 +3450,8 @@ package body Ch3 is
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
end if;
-- AI95-406 makes "aliased" legal (and useless) here.
-- AI95-406 makes "aliased" legal (and useless) here, so the
-- following code which used to be required is commented out.
-- if Aliased_Present then
-- Error_Msg_SP ("ALIASED not allowed here");

6
gcc/ada/prj.adb
View File

@ -24,6 +24,7 @@
------------------------------------------------------------------------------
with Debug;
with Opt;
with Osint; use Osint;
with Output; use Output;
with Prj.Attr;
@ -698,6 +699,11 @@ package body Prj is
Prj.Attr.Initialize;
-- Make sure that new reserved words after Ada 95 may be used as
-- identifiers.
Opt.Ada_Version := Opt.Ada_95;
Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project));
Set_Name_Table_Byte (Name_Extends, Token_Type'Pos (Tok_Extends));
Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));

96
gcc/ada/s-auxdec-vms-alpha.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1992-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- --
@ -218,26 +218,26 @@ package body System.Aux_DEC is
begin
System.Machine_Code.Asm
(
"lda $16, %3" & LF & HT &
"lda $16, %3" & LF & HT & -- Address of Bit
"mb" & LF & HT &
"sll $16, 3, $18 " & LF & HT &
"bis $31, 1, %1" & LF & HT &
"and $18, 63, $19" & LF & HT &
"bic $18, 63, $18" & LF & HT &
"sra $18, 3, $18" & LF & HT &
"bis $31, %4, $17" & LF & HT &
"sll %1, $19, $19" & LF & HT &
"sll $16, 3, $18 " & LF & HT & -- Byte address to bit address
"bis $31, 1, %1" & LF & HT & -- Set temp to 1 for the sll
"and $18, 63, $19" & LF & HT & -- Quadword bit offset
"bic $18, 63, $18" & LF & HT & -- Quadword bit address
"sra $18, 3, $18" & LF & HT & -- Quadword address
"bis $31, %4, $17" & LF & HT & -- Retry_Count -> $17
"sll %1, $19, $19" & LF & -- $19 = 1 << bit_offset
"1:" & LF & HT &
"ldq_l %2, 0($18)" & LF & HT &
"and %2, $19, %1" & LF & HT &
"bis %2, $19, %2" & LF & HT &
"stq_c %2, 0($18)" & LF & HT &
"beq %2, 2f" & LF & HT &
"cmovne %1, 1, %1" & LF & HT &
"br 3f" & LF & HT &
"ldq_l %2, 0($18)" & LF & HT & -- Load & lock
"and %2, $19, %1" & LF & HT & -- Previous value -> %1
"bis %2, $19, %2" & LF & HT & -- Set Bit
"stq_c %2, 0($18)" & LF & HT & -- Store conditional
"beq %2, 2f" & LF & HT & -- Goto 2: if failed
"cmovne %1, 1, %1" & LF & HT & -- Set Old_Bit
"br 3f" & LF &
"2:" & LF & HT &
"subq $17, 1, $17" & LF & HT &
"bgt $17, 1b" & LF & HT &
"subq $17, 1, $17" & LF & HT & -- Retry_Count - 1
"bgt $17, 1b" & LF & -- Retry ?
"3:" & LF & HT &
"mb" & LF & HT &
"trapb",
@ -331,7 +331,7 @@ package body System.Aux_DEC is
begin
System.Machine_Code.Asm
(
"mb" & LF & HT &
"mb" & LF &
"1:" & LF & HT &
"ldl_l $1, %0" & LF & HT &
"addl $1, %2, $0" & LF & HT &
@ -358,21 +358,21 @@ package body System.Aux_DEC is
System.Machine_Code.Asm
(
"mb" & LF & HT &
"bis $31, %5, $17" & LF & HT &
"bis $31, %5, $17" & LF &
"1:" & LF & HT &
"ldl_l $1, %0" & LF & HT &
"addl $1, %4, $0" & LF & HT &
"stl_c $0, %3" & LF & HT &
"beq $0, 2f" & LF & HT &
"beq $0, 2f" & LF &
"3:" & LF & HT &
"mb" & LF & HT &
"stq $0, %2" & LF & HT &
"stl $1, %1" & LF & HT &
"br 4f" & LF & HT &
"br 4f" & LF &
"2:" & LF & HT &
"subq $17, 1, $17" & LF & HT &
"bgt $17, 1b" & LF & HT &
"br 3b" & LF & HT &
"br 3b" & LF &
"4:",
Outputs => (Aligned_Integer'Asm_Output ("=m", To),
Integer'Asm_Output ("=m", Old_Value),
@ -393,7 +393,7 @@ package body System.Aux_DEC is
begin
System.Machine_Code.Asm
(
"mb" & LF & HT &
"mb" & LF &
"1:" & LF & HT &
"ldq_l $1, %0" & LF & HT &
"addq $1, %2, $0" & LF & HT &
@ -420,21 +420,21 @@ package body System.Aux_DEC is
System.Machine_Code.Asm
(
"mb" & LF & HT &
"bis $31, %5, $17" & LF & HT &
"bis $31, %5, $17" & LF &
"1:" & LF & HT &
"ldq_l $1, %0" & LF & HT &
"addq $1, %4, $0" & LF & HT &
"stq_c $0, %3" & LF & HT &
"beq $0, 2f" & LF & HT &
"beq $0, 2f" & LF &
"3:" & LF & HT &
"mb" & LF & HT &
"stq $0, %2" & LF & HT &
"stq $1, %1" & LF & HT &
"br 4f" & LF & HT &
"br 4f" & LF &
"2:" & LF & HT &
"subq $17, 1, $17" & LF & HT &
"bgt $17, 1b" & LF & HT &
"br 3b" & LF & HT &
"br 3b" & LF &
"4:",
Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To),
Long_Integer'Asm_Output ("=m", Old_Value),
@ -459,7 +459,7 @@ package body System.Aux_DEC is
begin
System.Machine_Code.Asm
(
"mb" & LF & HT &
"mb" & LF &
"1:" & LF & HT &
"ldl_l $1, %0" & LF & HT &
"and $1, %2, $0" & LF & HT &
@ -486,21 +486,21 @@ package body System.Aux_DEC is
System.Machine_Code.Asm
(
"mb" & LF & HT &
"bis $31, %5, $17" & LF & HT &
"bis $31, %5, $17" & LF &
"1:" & LF & HT &
"ldl_l $1, %0" & LF & HT &
"and $1, %4, $0" & LF & HT &
"stl_c $0, %3" & LF & HT &
"beq $0, 2f" & LF & HT &
"beq $0, 2f" & LF &
"3:" & LF & HT &
"mb" & LF & HT &
"stq $0, %2" & LF & HT &
"stl $1, %1" & LF & HT &
"br 4f" & LF & HT &
"br 4f" & LF &
"2:" & LF & HT &
"subq $17, 1, $17" & LF & HT &
"bgt $17, 1b" & LF & HT &
"br 3b" & LF & HT &
"br 3b" & LF &
"4:",
Outputs => (Aligned_Integer'Asm_Output ("=m", To),
Integer'Asm_Output ("=m", Old_Value),
@ -521,7 +521,7 @@ package body System.Aux_DEC is
begin
System.Machine_Code.Asm
(
"mb" & LF & HT &
"mb" & LF &
"1:" & LF & HT &
"ldq_l $1, %0" & LF & HT &
"and $1, %2, $0" & LF & HT &
@ -548,21 +548,21 @@ package body System.Aux_DEC is
System.Machine_Code.Asm
(
"mb" & LF & HT &
"bis $31, %5, $17" & LF & HT &
"bis $31, %5, $17" & LF &
"1:" & LF & HT &
"ldq_l $1, %0" & LF & HT &
"and $1, %4, $0" & LF & HT &
"stq_c $0, %3" & LF & HT &
"beq $0, 2f" & LF & HT &
"beq $0, 2f" & LF &
"3:" & LF & HT &
"mb" & LF & HT &
"stq $0, %2" & LF & HT &
"stq $1, %1" & LF & HT &
"br 4f" & LF & HT &
"br 4f" & LF &
"2:" & LF & HT &
"subq $17, 1, $17" & LF & HT &
"bgt $17, 1b" & LF & HT &
"br 3b" & LF & HT &
"br 3b" & LF &
"4:",
Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To),
Long_Integer'Asm_Output ("=m", Old_Value),
@ -587,7 +587,7 @@ package body System.Aux_DEC is
begin
System.Machine_Code.Asm
(
"mb" & LF & HT &
"mb" & LF &
"1:" & LF & HT &
"ldl_l $1, %0" & LF & HT &
"bis $1, %2, $0" & LF & HT &
@ -614,21 +614,21 @@ package body System.Aux_DEC is
System.Machine_Code.Asm
(
"mb" & LF & HT &
"bis $31, %5, $17" & LF & HT &
"bis $31, %5, $17" & LF &
"1:" & LF & HT &
"ldl_l $1, %0" & LF & HT &
"bis $1, %4, $0" & LF & HT &
"stl_c $0, %3" & LF & HT &
"beq $0, 2f" & LF & HT &
"beq $0, 2f" & LF &
"3:" & LF & HT &
"mb" & LF & HT &
"stq $0, %2" & LF & HT &
"stl $1, %1" & LF & HT &
"br 4f" & LF & HT &
"br 4f" & LF &
"2:" & LF & HT &
"subq $17, 1, $17" & LF & HT &
"bgt $17, 1b" & LF & HT &
"br 3b" & LF & HT &
"br 3b" & LF &
"4:",
Outputs => (Aligned_Integer'Asm_Output ("=m", To),
Integer'Asm_Output ("=m", Old_Value),
@ -649,7 +649,7 @@ package body System.Aux_DEC is
begin
System.Machine_Code.Asm
(
"mb" & LF & HT &
"mb" & LF &
"1:" & LF & HT &
"ldq_l $1, %0" & LF & HT &
"bis $1, %2, $0" & LF & HT &
@ -676,21 +676,21 @@ package body System.Aux_DEC is
System.Machine_Code.Asm
(
"mb" & LF & HT &
"bis $31, %5, $17" & LF & HT &
"bis $31, %5, $17" & LF &
"1:" & LF & HT &
"ldq_l $1, %0" & LF & HT &
"bis $1, %4, $0" & LF & HT &
"stq_c $0, %3" & LF & HT &
"beq $0, 2f" & LF & HT &
"beq $0, 2f" & LF &
"3:" & LF & HT &
"mb" & LF & HT &
"stq $0, %2" & LF & HT &
"stq $1, %1" & LF & HT &
"br 4f" & LF & HT &
"br 4f" & LF &
"2:" & LF & HT &
"subq $17, 1, $17" & LF & HT &
"bgt $17, 1b" & LF & HT &
"br 3b" & LF & HT &
"br 3b" & LF &
"4:",
Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To),
Long_Integer'Asm_Output ("=m", Old_Value),

7
gcc/ada/s-parint.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1995-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1995-2011, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -47,8 +47,9 @@ package System.Partition_Interface is
PCS_Version : constant := 1;
-- Version of the PCS API (for Exp_Dist consistency check).
-- This version number is matched against Gnatvsn.PCS_Version_Number to
-- ensure that the versions of Exp_Dist and the PCS are consistent.
-- This version number is matched against corresponding element of
-- Exp_Dist.PCS_Version_Number to ensure that the versions of Exp_Dist and
-- the PCS are consistent.
-- RCI receiving stubs contain a table of descriptors for
-- all user subprograms exported by the unit.

2
gcc/ada/sem_ch12.adb
View File

@ -2574,7 +2574,7 @@ package body Sem_Ch12 is
if Subp /= Any_Id then
-- Subprogram found, generate reference to it.
-- Subprogram found, generate reference to it
Set_Entity (Def, Subp);
Generate_Reference (Subp, Def);

4
gcc/ada/sem_ch13.adb
View File

@ -5767,8 +5767,8 @@ package body Sem_Ch13 is
A_Id = Aspect_Default_Iterator or else
A_Id = Aspect_Iterator_Element
then
-- Make type unfrozen before analysis, to prevent spurious
-- errors about late attributes.
-- Make type unfrozen before analysis, to prevent spurious errors
-- about late attributes.
Set_Is_Frozen (Ent, False);
Analyze (End_Decl_Expr);

4
gcc/ada/sem_ch3.adb
View File

@ -15003,8 +15003,8 @@ package body Sem_Ch3 is
Set_Has_Private_Declaration (Prev);
Set_Has_Private_Declaration (Id);
-- Preserve aspect and iterator flags, that may have been
-- set on the partial view.
-- Preserve aspect and iterator flags that may have been set on
-- the partial view.
Set_Has_Delayed_Aspects (Prev, Has_Delayed_Aspects (Id));
Set_Has_Implicit_Dereference (Prev, Has_Implicit_Dereference (Id));

9
gcc/ada/sem_ch4.adb
View File

@ -3345,6 +3345,9 @@ package body Sem_Ch4 is
Iterator : Node_Id;
begin
-- Analyze construct with expansion disabled, because it will be
-- rewritten as a loop during expansion.
Expander_Mode_Save_And_Set (False);
Check_SPARK_Restriction ("quantified expression is not allowed", N);
@ -3367,9 +3370,9 @@ package body Sem_Ch4 is
Set_Parent (Iterator, N);
Analyze_Iteration_Scheme (Iterator);
-- The loop specification may have been converted into an
-- iterator specification during its analysis. Update the
-- quantified node accordingly.
-- The loop specification may have been converted into an iterator
-- specification during its analysis. Update the quantified node
-- accordingly.
if Present (Iterator_Specification (Iterator)) then
Set_Iterator_Specification

52
gcc/ada/sem_ch5.adb
View File

@ -2006,22 +2006,20 @@ package body Sem_Ch5 is
Set_Parent (D_Copy, Parent (DS));
Pre_Analyze_Range (D_Copy);
-- Ada2012 : if the domain of iteration is a function call,
-- Ada2012: If the domain of iteration is a function call,
-- it is the new iterator form.
-- We have also implemented the shorter form : for X in S
-- for Alfa use. In this case the attributes Old and Result
-- must be treated as entity names over which iterators are
-- legal.
-- for Alfa use. In this case, 'Old and 'Result must be
-- treated as entity names over which iterators are legal.
if Nkind (D_Copy) = N_Function_Call
or else
(ALFA_Mode
and then (Nkind (D_Copy) = N_Attribute_Reference
and then
(Attribute_Name (D_Copy) = Name_Result
and then (Nkind (D_Copy) = N_Attribute_Reference
and then
(Attribute_Name (D_Copy) = Name_Result
or else Attribute_Name (D_Copy) = Name_Old)))
or else
(Is_Entity_Name (D_Copy)
and then not Is_Type (Entity (D_Copy)))
@ -2044,8 +2042,8 @@ package body Sem_Ch5 is
Set_Loop_Parameter_Specification (N, Empty);
Analyze_Iterator_Specification (I_Spec);
-- In a generic context, analyze the original
-- domain of iteration, for name capture.
-- In a generic context, analyze the original domain
-- of iteration, for name capture.
if not Expander_Active then
Analyze (DS);
@ -2267,22 +2265,21 @@ package body Sem_Ch5 is
Object_Definition => New_Occurrence_Of (Typ, Loc),
Expression => Relocate_Node (Iter_Name));
Insert_Actions
(Parent (Parent (N)), New_List (Decl));
Insert_Actions (Parent (Parent (N)), New_List (Decl));
Rewrite (Name (N), New_Occurrence_Of (Id, Loc));
Set_Etype (Id, Typ);
Set_Etype (Name (N), Typ);
end;
-- Container is an entity or an array with uncontrolled components, or
-- else it is a container iterator given by a function call, typically
-- called Iterate in the case of predefined containers, even though
-- Iterate is not a reserved name. What matter is that the return type
-- of the function is an iterator type.
else
-- Container is an entity or an array with uncontrolled components,
-- or else it is a container iterator given by a function call,
-- typically called Iterate in the case of predefined containers,
-- even though Iterate is not a reserved name. What matter is that
-- the return type of the function is an iterator type.
Analyze (Iter_Name);
if Nkind (Iter_Name) = N_Function_Call then
declare
C : constant Node_Id := Name (Iter_Name);
@ -2312,10 +2309,9 @@ package body Sem_Ch5 is
end if;
end;
-- Domain of iteration is not overloaded
else
-- domain of iteration is not overloaded.
Resolve (Iter_Name, Etype (Iter_Name));
end if;
end if;
@ -2331,7 +2327,7 @@ package body Sem_Ch5 is
Set_Etype (Def_Id, Etype (First_Index (Typ)));
end if;
-- Check for type error in iterator.
-- Check for type error in iterator
elsif Typ = Any_Type then
return;
@ -2343,16 +2339,16 @@ package body Sem_Ch5 is
if Of_Present (N) then
-- The type of the loop variable is the Iterator_Element
-- aspect of the container type.
-- The type of the loop variable is the Iterator_Element aspect of
-- the container type.
Set_Etype (Def_Id,
Entity (Find_Aspect (Typ, Aspect_Iterator_Element)));
else
-- The result type of Iterate function is the classwide type
-- of the interface parent. We need the specific Cursor type
-- defined in the container package.
-- The result type of Iterate function is the classwide type of
-- the interface parent. We need the specific Cursor type defined
-- in the container package.
Ent := First_Entity (Scope (Typ));
while Present (Ent) loop

2
gcc/ada/sem_res.adb
View File

@ -4381,7 +4381,7 @@ package body Sem_Res is
end if;
end if;
-- Report a simple error: if the designated object is a local task,
-- Report a simple error: if the designated object is a local task,
-- its body has not been seen yet, and its activation will fail an
-- elaboration check.

95
gcc/ada/sem_util.adb
View File

@ -7178,16 +7178,15 @@ package body Sem_Util is
if Is_Class_Wide_Type (Typ)
and then
(Chars (Etype (Typ)) = Name_Forward_Iterator
or else Chars (Etype (Typ)) = Name_Reversible_Iterator)
or else
Chars (Etype (Typ)) = Name_Reversible_Iterator)
and then
Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (Etype (Typ))))
then
return True;
elsif not Is_Tagged_Type (Typ)
or else not Is_Derived_Type (Typ)
then
elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then
return False;
else
@ -7211,50 +7210,6 @@ package body Sem_Util is
end if;
end Is_Iterator;
----------------------------
-- Is_Reversible_Iterator --
----------------------------
function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is
Ifaces_List : Elist_Id;
Iface_Elmt : Elmt_Id;
Iface : Entity_Id;
begin
if Is_Class_Wide_Type (Typ)
and then Chars (Etype (Typ)) = Name_Reversible_Iterator
and then
Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (Etype (Typ))))
then
return True;
elsif not Is_Tagged_Type (Typ)
or else not Is_Derived_Type (Typ)
then
return False;
else
Collect_Interfaces (Typ, Ifaces_List);
Iface_Elmt := First_Elmt (Ifaces_List);
while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
if Chars (Iface) = Name_Reversible_Iterator
and then
Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (Iface)))
then
return True;
end if;
Next_Elmt (Iface_Elmt);
end loop;
end if;
return False;
end Is_Reversible_Iterator;
------------
-- Is_LHS --
------------
@ -7898,6 +7853,50 @@ package body Sem_Util is
return False;
end Is_Renamed_Entry;
----------------------------
-- Is_Reversible_Iterator --
----------------------------
function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is
Ifaces_List : Elist_Id;
Iface_Elmt : Elmt_Id;
Iface : Entity_Id;
begin
if Is_Class_Wide_Type (Typ)
and then Chars (Etype (Typ)) = Name_Reversible_Iterator
and then
Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (Etype (Typ))))
then
return True;
elsif not Is_Tagged_Type (Typ)
or else not Is_Derived_Type (Typ)
then
return False;
else
Collect_Interfaces (Typ, Ifaces_List);
Iface_Elmt := First_Elmt (Ifaces_List);
while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
if Chars (Iface) = Name_Reversible_Iterator
and then
Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (Iface)))
then
return True;
end if;
Next_Elmt (Iface_Elmt);
end loop;
end if;
return False;
end Is_Reversible_Iterator;
----------------------
-- Is_Selector_Name --
----------------------