+2011-08-29 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_res.adb: Remove Build_Explicit_Dereference.
+ * sem_util.adb, sem_util.ads (Build_Explicit_Dereference): Moved here
+ from sem_res.adb, used in analysis of additional constructs.
+ (Is_Iterator, Is_Reversible_Iterator): New predicates for Ada2012
+ expansion of iterators.
+ (Is_Object_Reference): Recognize variables rewritten as explicit
+ dereferences in Ada2012.
+ * snames.ads-tmpl: Add Has_Element, Forward_Iterator,
+ Reversible_Iterator names, for expansion of Ada2012 iterators.
+ * aspects.ads, aspects.adb (Find_Aspect): Utility.
+ * a-cdlili.ads, a-cdlili.adb: Add new iterator machinery to doubly
+ linked list container.
+ * a-coinve.ads, a-coinve.adb: Ditto for indefinite vector containers.
+ * a-coorse.ads, a-coorse.adb: Ditto for ordered sets.
+
+2011-08-29 Ed Schonberg <schonberg@adacore.com>
+
+ * a-cohama.adb, a-cohama.ads: Add iterator primitives to hashed map
+ containers.
+
+2011-08-29 Vincent Celier <celier@adacore.com>
+
+ * make.adb (Gnatmake): Get the maximum number of simultaneous
+ compilation processes after the Builder switches has been scanned, as
+ there may include -jnn.
+
+2011-08-29 Matthew Heaney <heaney@adacore.com>
+
+ * a-chtgbo.adb (Generic_Equal): Use correct overloading of Next.
+
+2011-08-29 Tristan Gingold <gingold@adacore.com>
+
+ * gnatcmd.adb (GNATCmd): On OpenVMS, truncate the length of
+ GNAT_DRIVER_COMMAND_LINE to 255.
+
+2011-08-29 Pascal Obry <obry@adacore.com>
+
+ * freeze.adb, sem_ch8.adb, a-convec.adb, a-convec.ads: Minor
+ reformatting and style fix (class attribute casing).
+
+2011-08-29 Yannick Moy <moy@adacore.com>
+
+ * exp_ch11.adb: Yet another case where expansion should be common
+ between CodePeer and Alfa.
+
+2011-08-29 Yannick Moy <moy@adacore.com>
+
+ * exp_ch9.adb: Partial revert of previous change for Alfa mode.
+
+2011-08-29 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Matches_Limited_With_View): The limited views of an
+ incomplete type and its completion match.
+
2011-08-29 Yannick Moy <moy@adacore.com>
* exp_ch13.adb: Adjust previous change.
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-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- --
with Ada.Unchecked_Deallocation;
package body Ada.Containers.Doubly_Linked_Lists is
+ type Iterator is new
+ List_Iterator_Interfaces.Reversible_Iterator with record
+ Container : List_Access;
+ 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;
-----------------------
-- Local Subprograms --
return Cursor'(Container'Unchecked_Access, Container.First);
end First;
+ function First (Object : Iterator) return Cursor is
+ C : constant Cursor := (Object.Container, Object.Container.First);
+ begin
+ return C;
+ end First;
+
-------------------
-- First_Element --
-------------------
B := B - 1;
end Iterate;
+ 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
+ is
+ It : constant Iterator := (Container'Unchecked_Access, Start.Node);
+ begin
+ return It;
+ end Iterate;
+
----------
-- Last --
----------
return Cursor'(Container'Unchecked_Access, Container.Last);
end Last;
+ function Last (Object : Iterator) return Cursor is
+ C : constant Cursor := (Object.Container, Object.Container.Last);
+ begin
+ return C;
+ end Last;
+
------------------
-- Last_Element --
------------------
end;
end Next;
+ function Next (Object : Iterator; Position : Cursor) return Cursor is
+ begin
+ if Position.Node = Object.Container.Last then
+ return No_Element;
+
+ else
+ return (Object.Container, Position.Node.Next);
+ end if;
+ end Next;
+
-------------
-- Prepend --
-------------
end;
end Previous;
+ function Previous (Object : Iterator; Position : Cursor) return Cursor is
+ begin
+ if Position.Node = Position.Container.First then
+ return No_Element;
+
+ else
+ return (Object.Container, Position.Node.Prev);
+ end if;
+ end Previous;
+
-------------------
-- Query_Element --
-------------------
raise Program_Error with "attempt to stream list cursor";
end Read;
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Constant_Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Read;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Constant_Reference (Container : List; Position : Cursor)
+ return Constant_Reference_Type is
+ begin
+ pragma Unreferenced (Container);
+
+ if Position.Container = null then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ return (Element => Position.Node.Element'Access);
+ end Constant_Reference;
+
+ function Reference (Container : List; Position : Cursor)
+ return Reference_Type is
+ begin
+ pragma Unreferenced (Container);
+
+ if Position.Container = null then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ return (Element => Position.Node.Element'Access);
+ end Reference;
+
---------------------
-- Replace_Element --
---------------------
raise Program_Error with "attempt to stream list cursor";
end Write;
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Constant_Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Write;
+
end Ada.Containers.Doubly_Linked_Lists;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
------------------------------------------------------------------------------
private with Ada.Finalization;
-private with Ada.Streams;
+with Ada.Streams; use Ada.Streams;
+with Ada.Iterator_Interfaces;
generic
type Element_Type is private;
pragma Preelaborate;
pragma Remote_Types;
- type List is tagged private;
+ type List is tagged private
+ with
+ Constant_Indexing => Constant_Reference,
+ Variable_Indexing => Reference,
+ Default_Iterator => Iterate,
+ Iterator_Element => Element_Type;
+
pragma Preelaborable_Initialization (List);
type Cursor is private;
Empty_List : constant List;
No_Element : constant Cursor;
+ function Has_Element (Position : Cursor) return Boolean;
+
+ package List_Iterator_Interfaces is new
+ Ada.Iterator_Interfaces (Cursor, Has_Element);
function "=" (Left, Right : List) return Boolean;
procedure Reverse_Elements (Container : in out List);
+ function Iterate (Container : List)
+ return List_Iterator_Interfaces.Reversible_Iterator'class;
+
+ function Iterate (Container : List; Start : Cursor)
+ return List_Iterator_Interfaces.Reversible_Iterator'class;
+
procedure Swap
(Container : in out List;
I, J : Cursor);
(Container : List;
Item : Element_Type) return Boolean;
- function Has_Element (Position : Cursor) return Boolean;
-
procedure Iterate
(Container : List;
Process : not null access procedure (Position : Cursor));
end Generic_Sorting;
+ type Constant_Reference_Type
+ (Element : not null access constant Element_Type) is private
+ with
+ Implicit_Dereference => Element;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Constant_Reference_Type);
+
+ for Constant_Reference_Type'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Constant_Reference_Type);
+
+ for Constant_Reference_Type'Read use Read;
+
+ type Reference_Type (Element : not null access Element_Type) is
+ private
+ with
+ Implicit_Dereference => Element;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Reference_Type);
+
+ for Reference_Type'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Reference_Type);
+
+ for Reference_Type'Read use Read;
+
+ function Constant_Reference
+ (Container : List; Position : Cursor) -- SHOULD BE ALIASED
+ return Constant_Reference_Type;
+
+ function Reference
+ (Container : List; Position : Cursor) -- SHOULD BE ALIASED
+ return Reference_Type;
+
private
pragma Inline (Next);
type Node_Type is
limited record
- Element : Element_Type;
+ Element : aliased Element_Type;
Next : Node_Access;
Prev : Node_Access;
end record;
overriding procedure Finalize (Container : in out List) renames Clear;
- use Ada.Streams;
-
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Item : out List);
for Cursor'Write use Write;
+ type Constant_Reference_Type
+ (Element : not null access constant Element_Type) is null record;
+
+ type Reference_Type
+ (Element : not null access Element_Type) is null record;
+
Empty_List : constant List := (Controlled with null, null, 0, 0, 0);
No_Element : constant Cursor := Cursor'(null, null);
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-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- --
-- Find the first node of hash table L
- L_Index := 0;
+ L_Index := L.Buckets'First;
loop
L_Node := L.Buckets (L_Index);
exit when L_Node /= 0;
N := N - 1;
- L_Node := Next (L, L_Node);
+ L_Node := Next (L.Nodes (L_Node));
if L_Node = 0 then
-- We have exhausted the nodes in this bucket
package body Ada.Containers.Hashed_Maps is
+ type Iterator is new
+ Map_Iterator_Interfaces.Forward_Iterator with 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;
+
-----------------------
-- Local Subprograms --
-----------------------
return Cursor'(Container'Unchecked_Access, Node);
end First;
+ function First (Object : Iterator) return Cursor is
+ M : constant Map_Access := Object.Container;
+ N : constant Node_Access := HT_Ops.First (M.HT);
+ begin
+ if N = null then
+ return No_Element;
+ end if;
+
+ return Cursor'(Object.Container.all'Unchecked_Access, N);
+ end First;
+
----------
-- Free --
----------
B := B - 1;
end Iterate;
+ function Iterate (Container : Map)
+ return Map_Iterator_Interfaces.Forward_Iterator'class
+ is
+ Node : constant Node_Access := HT_Ops.First (Container.HT);
+ It : constant Iterator := (Container'Unrestricted_Access, Node);
+ begin
+ return It;
+ end Iterate;
+
---------
-- Key --
---------
Position := Next (Position);
end Next;
+ function Next (Object : Iterator; Position : Cursor) return Cursor is
+ begin
+ if Position.Node = null then
+ return No_Element;
+
+ else
+ return (Object.Container, Next (Position).Node);
+ end if;
+ end Next;
+
-------------------
-- Query_Element --
-------------------
raise Program_Error with "attempt to stream map cursor";
end Read;
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Constant_Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Read;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Constant_Reference (Container : Map; Key : Key_Type)
+ return Constant_Reference_Type is
+ begin
+ return (Element => Container.Element (Key)'Unrestricted_Access);
+ end Constant_Reference;
+
+ function Reference (Container : Map; Key : Key_Type)
+ return Reference_Type is
+ begin
+ return (Element => Container.Element (Key)'Unrestricted_Access);
+ end Reference;
+
---------------
-- Read_Node --
---------------
raise Program_Error with "attempt to stream map cursor";
end Write;
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Constant_Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Write;
+
----------------
-- Write_Node --
----------------
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
------------------------------------------------------------------------------
private with Ada.Containers.Hash_Tables;
-private with Ada.Streams;
+with Ada.Streams; use Ada.Streams;
private with Ada.Finalization;
+with Ada.Iterator_Interfaces;
generic
type Key_Type is private;
pragma Preelaborate;
pragma Remote_Types;
- type Map is tagged private;
+ type Map is tagged private
+ with
+ Constant_Indexing => Constant_Reference,
+ Variable_Indexing => Reference,
+ Default_Iterator => Iterate,
+ Iterator_Element => Element_Type;
+
pragma Preelaborable_Initialization (Map);
type Cursor is private;
pragma Preelaborable_Initialization (Cursor);
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Cursor);
+
+ for Cursor'Read use Read;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Cursor);
+
+ for Cursor'Write use Write;
+
Empty_Map : constant Map;
-- Map objects declared without an initialization expression are
-- initialized to the value Empty_Map.
-- Cursor objects declared without an initialization expression are
-- initialized to the value No_Element.
+ function Has_Element (Position : Cursor) return Boolean;
+ -- Equivalent to Position /= No_Element
+
+ package Map_Iterator_Interfaces is new
+ Ada.Iterator_Interfaces (Cursor, Has_Element);
+
function "=" (Left, Right : Map) return Boolean;
-- For each key/element pair in Left, equality attempts to find the key in
-- Right; if a search fails the equality returns False. The search works by
function Element (Container : Map; Key : Key_Type) return Element_Type;
-- Equivalent to Element (Find (Container, Key))
- function Has_Element (Position : Cursor) return Boolean;
- -- Equivalent to Position /= No_Element
-
function Equivalent_Keys (Left, Right : Cursor) return Boolean;
-- Returns the result of calling Equivalent_Keys with the keys of the nodes
-- designated by cursors Left and Right.
-- Returns the result of calling Equivalent_Keys with key Left and the node
-- designated by Right.
+ type Constant_Reference_Type
+ (Element : not null access constant Element_Type) is private
+ with
+ Implicit_Dereference => Element;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Constant_Reference_Type);
+
+ for Constant_Reference_Type'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Constant_Reference_Type);
+
+ for Constant_Reference_Type'Read use Read;
+
+ type Reference_Type (Element : not null access Element_Type) is private
+ with
+ Implicit_Dereference => Element;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Reference_Type);
+
+ for Reference_Type'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Reference_Type);
+
+ for Reference_Type'Read use Read;
+
+ function Constant_Reference
+ (Container : Map; Key : Key_Type) -- SHOULD BE ALIASED
+ return Constant_Reference_Type;
+
+ function Reference (Container : Map; Key : Key_Type)
+ return Reference_Type;
+
procedure Iterate
(Container : Map;
Process : not null access procedure (Position : Cursor));
-- Calls Process for each node in the map
+ function Iterate (Container : Map)
+ return Map_Iterator_Interfaces.Forward_Iterator'class;
+
private
pragma Inline ("=");
pragma Inline (Length);
overriding procedure Finalize (Container : in out Map);
- use Ada.Streams;
-
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Container : Map);
Node : Node_Access;
end record;
- procedure Read
- (Stream : not null access Root_Stream_Type'Class;
- Item : out Cursor);
+ type Constant_Reference_Type
+ (Element : not null access constant Element_Type) is null record;
- for Cursor'Read use Read;
-
- procedure Write
- (Stream : not null access Root_Stream_Type'Class;
- Item : Cursor);
-
- for Cursor'Write use Write;
+ type Reference_Type
+ (Element : not null access Element_Type) is null record;
Empty_Map : constant Map := (Controlled with HT => (null, 0, 0, 0));
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-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- --
procedure Free is
new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
+ type Iterator is new
+ Vector_Iterator_Interfaces.Reversible_Iterator with record
+ Container : Vector_Access;
+ Index : Index_Type;
+ 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;
+
---------
-- "&" --
---------
return (Container'Unchecked_Access, Index_Type'First);
end First;
+ function First (Object : Iterator) return Cursor is
+ C : constant Cursor := (Object.Container, Index_Type'First);
+ begin
+ return C;
+ end First;
+
-------------------
-- First_Element --
-------------------
B := B - 1;
end Iterate;
+ function Iterate (Container : Vector)
+ return Vector_Iterator_Interfaces.Reversible_Iterator'class
+ is
+ It : constant Iterator := (Container'Unchecked_Access, Index_Type'First);
+ begin
+ return It;
+ end Iterate;
+
+ function Iterate (Container : Vector; Start : Cursor)
+ return Vector_Iterator_Interfaces.Reversible_Iterator'class
+ is
+ It : constant Iterator :=
+ (Container'Unchecked_Access, Start.Index);
+ begin
+ return It;
+ end Iterate;
+
----------
-- Last --
----------
return (Container'Unchecked_Access, Container.Last);
end Last;
+ function Last (Object : Iterator) return Cursor is
+ C : constant Cursor := (Object.Container, Object.Container.Last);
+ begin
+ return C;
+ end Last;
+
-----------------
-- Last_Element --
------------------
return No_Element;
end Next;
+ function Next (Object : Iterator; Position : Cursor) return Cursor is
+ begin
+ if Position.Index = Object.Container.Last then
+ return No_Element;
+ else
+ return (Object.Container, Position.Index + 1);
+ end if;
+ end Next;
+
----------
-- Next --
----------
return No_Element;
end Previous;
+ function Previous (Object : Iterator; Position : Cursor) return Cursor is
+ begin
+ if Position.Index > Index_Type'First then
+ return (Object.Container, Position.Index - 1);
+ else
+ return No_Element;
+ end if;
+ end Previous;
+
-------------------
-- Query_Element --
-------------------
raise Program_Error with "attempt to stream vector cursor";
end Read;
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Constant_Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Read;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Constant_Reference
+ (Container : Vector; Position : Cursor) -- SHOULD BE ALIASED
+ return Constant_Reference_Type is
+ begin
+ pragma Unreferenced (Container);
+
+ if Position.Container = null then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ if Position.Index > Position.Container.Last then
+ raise Constraint_Error with "Position cursor is out of range";
+ end if;
+
+ return
+ (Element => Position.Container.Elements.EA (Position.Index).all'Access);
+ end Constant_Reference;
+
+ function Constant_Reference
+ (Container : Vector; Position : Index_Type)
+ return Constant_Reference_Type is
+ begin
+ if (Position) > Container.Last then
+ raise Constraint_Error with "Index is out of range";
+ end if;
+
+ return (Element => Container.Elements.EA (Position).all'Access);
+ end Constant_Reference;
+
+ function Reference (Container : Vector; Position : Cursor)
+ return Reference_Type is
+ begin
+ pragma Unreferenced (Container);
+
+ if Position.Container = null then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ if Position.Index > Position.Container.Last then
+ raise Constraint_Error with "Position cursor is out of range";
+ end if;
+
+ return
+ (Element =>
+ Position.Container.Elements.EA (Position.Index).all'Access);
+ end Reference;
+
+ function Reference (Container : Vector; Position : Index_Type)
+ return Reference_Type is
+ begin
+ if Position > Container.Last then
+ raise Constraint_Error with "Index is out of range";
+ end if;
+
+ return (Element => Container.Elements.EA (Position).all'Access);
+ end Reference;
+
---------------------
-- Replace_Element --
---------------------
raise Program_Error with "attempt to stream vector cursor";
end Write;
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Constant_Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Write;
+
end Ada.Containers.Indefinite_Vectors;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
------------------------------------------------------------------------------
private with Ada.Finalization;
-private with Ada.Streams;
+with Ada.Streams; use Ada.Streams;
+with Ada.Iterator_Interfaces;
generic
type Index_Type is range <>;
No_Index : constant Extended_Index := Extended_Index'First;
- type Vector is tagged private;
+ type Vector is tagged private
+ with
+ Constant_Indexing => Constant_Reference,
+ Variable_Indexing => Reference,
+ Default_Iterator => Iterate,
+ Iterator_Element => Element_Type;
+
pragma Preelaborable_Initialization (Vector);
type Cursor is private;
Empty_Vector : constant Vector;
No_Element : constant Cursor;
+ function Has_Element (Position : Cursor) return Boolean;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Position : out Cursor);
+
+ for Cursor'Read use Read;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Position : Cursor);
+
+ for Cursor'Write use Write;
+
+ package Vector_Iterator_Interfaces is new
+ Ada.Iterator_Interfaces (Cursor, Has_Element);
overriding function "=" (Left, Right : Vector) return Boolean;
procedure Clear (Container : in out Vector);
+ type Constant_Reference_Type
+ (Element : not null access constant Element_Type) is private
+ with
+ Implicit_Dereference => Element;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Constant_Reference_Type);
+
+ for Constant_Reference_Type'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Constant_Reference_Type);
+
+ for Constant_Reference_Type'Read use Read;
+
+ type Reference_Type (Element : not null access Element_Type) is private
+ with
+ Implicit_Dereference => Element;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Reference_Type);
+
+ for Reference_Type'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Reference_Type);
+
+ for Reference_Type'Read use Read;
+
+ function Constant_Reference
+ (Container : Vector; Position : Cursor) -- SHOULD BE ALIASED
+ return Constant_Reference_Type;
+
+ function Constant_Reference
+ (Container : Vector; Position : Index_Type)
+ return Constant_Reference_Type;
+
+ function Reference (Container : Vector; Position : Cursor)
+ return Reference_Type;
+
+ function Reference (Container : Vector; Position : Index_Type)
+ return Reference_Type;
+
function To_Cursor
(Container : Vector;
Index : Extended_Index) return Cursor;
(Container : Vector;
Item : Element_Type) return Boolean;
- function Has_Element (Position : Cursor) return Boolean;
-
procedure Iterate
(Container : Vector;
Process : not null access procedure (Position : Cursor));
+ function Iterate (Container : Vector)
+ return Vector_Iterator_Interfaces.Reversible_Iterator'class;
+
+ function Iterate (Container : Vector; Start : Cursor)
+ return Vector_Iterator_Interfaces.Reversible_Iterator'class;
+
procedure Reverse_Iterate
(Container : Vector;
Process : not null access procedure (Position : Cursor));
Lock : Natural := 0;
end record;
+ type Constant_Reference_Type
+ (Element : not null access constant Element_Type) is null record;
+
+ type Reference_Type
+ (Element : not null access Element_Type) is null record;
+
overriding procedure Adjust (Container : in out Vector);
overriding procedure Finalize (Container : in out Vector);
- use Ada.Streams;
-
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Container : Vector);
Index : Index_Type := Index_Type'First;
end record;
- procedure Write
- (Stream : not null access Root_Stream_Type'Class;
- Position : Cursor);
-
- for Cursor'Write use Write;
-
- procedure Read
- (Stream : not null access Root_Stream_Type'Class;
- Position : out Cursor);
-
- for Cursor'Read use Read;
-
Empty_Vector : constant Vector := (Controlled with null, No_Index, 0, 0);
No_Element : constant Cursor := Cursor'(null, Index_Type'First);
end Iterate;
function Iterate (Container : Vector)
- return Vector_Iterator_Interfaces.Reversible_Iterator'class
+ return Vector_Iterator_Interfaces.Reversible_Iterator'Class
is
It : constant Iterator := (Container'Unchecked_Access, Index_Type'First);
begin
end Iterate;
function Iterate (Container : Vector; Start : Cursor)
- return Vector_Iterator_Interfaces.Forward_Iterator'class
+ return Vector_Iterator_Interfaces.Forward_Iterator'Class
is
It : constant Iterator :=
(Container'Unchecked_Access, Start.Index);
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
Process : not null access procedure (Position : Cursor));
function Iterate (Container : Vector)
- return Vector_Iterator_Interfaces.Reversible_Iterator'class;
+ return Vector_Iterator_Interfaces.Reversible_Iterator'Class;
function Iterate (Container : Vector; Start : Cursor)
- return Vector_Iterator_Interfaces.Forward_Iterator'class;
+ return Vector_Iterator_Interfaces.Forward_Iterator'Class;
generic
with function "<" (Left, Right : Element_Type) return Boolean is <>;
package body Ada.Containers.Ordered_Sets is
+ type Iterator is new
+ Ordered_Set_Iterator_Interfaces.Reversible_Iterator with 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;
+
------------------------------
-- Access to Fields of Node --
------------------------------
return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
end First;
+ function First (Object : Iterator) return Cursor is
+ begin
+ return Cursor'(
+ Object.Container.all'Unrestricted_Access, Object.Container.Tree.First);
+ end First;
+
-------------------
-- First_Element --
-------------------
B := B - 1;
end Iterate;
+ function Iterate (Container : Set)
+ return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class
+ is
+ It : constant Iterator :=
+ (Container'Unchecked_Access, Container.Tree.First);
+ begin
+ return It;
+ end Iterate;
+
+ function Iterate (Container : Set; Start : Cursor)
+ return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class
+ is
+ It : constant Iterator := (Container'Unchecked_Access, Start.Node);
+ begin
+ return It;
+ end Iterate;
+
----------
-- Last --
----------
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;
+ end if;
+
+ return Cursor'(
+ Object.Container.all'Unrestricted_Access, Object.Container.Tree.Last);
+ end Last;
+
------------------
-- Last_Element --
------------------
Position := Next (Position);
end Next;
+ function Next (Object : Iterator; Position : Cursor)
+ return Cursor
+ is
+ pragma Unreferenced (Object);
+ begin
+ return Next (Position);
+ end Next;
+
-------------
-- Overlap --
-------------
Position := Previous (Position);
end Previous;
+ overriding function Previous (Object : Iterator; Position : Cursor)
+ return Cursor
+ is
+ pragma Unreferenced (Object);
+ begin
+ return Previous (Position);
+ end Previous;
-------------------
-- Query_Element --
-------------------
raise Program_Error with "attempt to stream set cursor";
end Read;
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Constant_Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Read;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Constant_Reference (Container : Set; Position : Cursor)
+ return Constant_Reference_Type
+ is
+ pragma Unreferenced (Container);
+ begin
+ if Position.Container = null then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ return (Element => Position.Node.Element'Access);
+ end Constant_Reference;
+
+ function Reference (Container : Set; Position : Cursor)
+ return Reference_Type
+ is
+ pragma Unreferenced (Container);
+ begin
+ if Position.Container = null then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ return (Element => Position.Node.Element'Access);
+ end Reference;
+
-------------
-- Replace --
-------------
raise Program_Error with "attempt to stream set cursor";
end Write;
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Constant_Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Write;
+
end Ada.Containers.Ordered_Sets;
private with Ada.Containers.Red_Black_Trees;
private with Ada.Finalization;
-private with Ada.Streams;
+with Ada.Streams; use Ada.Streams;
+with Ada.Iterator_Interfaces;
generic
type Element_Type is private;
function Equivalent_Elements (Left, Right : Element_Type) return Boolean;
- type Set is tagged private;
+ type Set is tagged private
+ with
+ Constant_Indexing => Constant_Reference,
+ Variable_Indexing => Reference,
+ Default_Iterator => Iterate,
+ Iterator_Element => Element_Type;
+
pragma Preelaborable_Initialization (Set);
type Cursor is private;
pragma Preelaborable_Initialization (Cursor);
+ function Has_Element (Position : Cursor) return Boolean;
+
Empty_Set : constant Set;
No_Element : constant Cursor;
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Cursor);
+
+ for Cursor'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Cursor);
+
+ for Cursor'Read use Read;
+
+ 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
+ Implicit_Dereference => Element;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Constant_Reference_Type);
+
+ for Constant_Reference_Type'Write use Write;
+
+ function Constant_Reference
+ (Container : Set; Position : Cursor)
+ return Constant_Reference_Type;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Constant_Reference_Type);
+
+ for Constant_Reference_Type'Read use Read;
+
+ type Reference_Type (Element : not null access Element_Type) is private
+ with
+ Implicit_Dereference => Element;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Reference_Type);
+
+ for Reference_Type'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Reference_Type);
+
+ for Reference_Type'Read use Read;
+
+ function Reference
+ (Container : Set; Position : Cursor)
+ return Reference_Type;
+
function "=" (Left, Right : Set) return Boolean;
function Equivalent_Sets (Left, Right : Set) return Boolean;
function Contains (Container : Set; Item : Element_Type) return Boolean;
- function Has_Element (Position : Cursor) return Boolean;
-
function "<" (Left, Right : Cursor) return Boolean;
function ">" (Left, Right : Cursor) return Boolean;
(Container : Set;
Process : not null access procedure (Position : Cursor));
+ function Iterate (Container : Set)
+ return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class;
+
+ function Iterate (Container : Set; Start : Cursor)
+ return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class;
+
generic
type Key_Type (<>) is private;
Left : Node_Access;
Right : Node_Access;
Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red;
- Element : Element_Type;
+ Element : aliased Element_Type;
end record;
package Tree_Types is
use Red_Black_Trees;
use Tree_Types;
use Ada.Finalization;
- use Ada.Streams;
type Set_Access is access all Set;
for Set_Access'Storage_Size use 0;
Node : Node_Access;
end record;
- procedure Write
- (Stream : not null access Root_Stream_Type'Class;
- Item : Cursor);
-
- for Cursor'Write use Write;
-
- procedure Read
- (Stream : not null access Root_Stream_Type'Class;
- Item : out Cursor);
-
- for Cursor'Read use Read;
-
No_Element : constant Cursor := Cursor'(null, null);
procedure Write
for Set'Read use Read;
+ type Constant_Reference_Type
+ (Element : not null access constant Element_Type) is null record;
+
+ type Reference_Type
+ (Element : not null access Element_Type) is null record;
+
Empty_Set : constant Set :=
(Controlled with Tree => (First => null,
Last => null,
------------------------------------------------------------------------------
with Atree; use Atree;
+with Einfo; use Einfo;
with Nlists; use Nlists;
with Sinfo; use Sinfo;
with Tree_IO; use Tree_IO;
return Aspect_Id_Hash_Table.Get (Name);
end Get_Aspect_Id;
+ -----------------
+ -- Find_Aspect --
+ -----------------
+
+ function Find_Aspect (Ent : Entity_Id; A : Aspect_Id) return Node_Id is
+ Ritem : Node_Id;
+
+ begin
+ Ritem := First_Rep_Item (Ent);
+ while Present (Ritem) loop
+ if Nkind (Ritem) = N_Aspect_Specification
+ and then Get_Aspect_Id (Chars (Identifier (Ritem))) = A
+ then
+ if A = Aspect_Default_Iterator then
+ return Expression (Aspect_Rep_Item (Ritem));
+ else
+ return Expression (Ritem);
+ end if;
+ end if;
+
+ Next_Rep_Item (Ritem);
+ end loop;
+
+ return Empty;
+ end Find_Aspect;
+
------------------
-- Move_Aspects --
------------------
-- node that has its Has_Aspects flag set True on entry, or with L being an
-- empty list or No_List.
+ function Find_Aspect (Ent : Entity_Id; A : Aspect_Id) return Node_Id;
+ -- Find value of a given aspect from aspect list of entity.
+
procedure Move_Aspects (From : Node_Id; To : Node_Id);
-- Moves aspects from 'From' node to 'To' node. Has_Aspects (To) must be
-- False on entry. If Has_Aspects (From) is False, the call has no effect.
else
-- Bypass expansion to a run-time call when back-end exception
- -- handling is active, unless the target is a VM or CodePeer.
+ -- handling is active, unless the target is a VM, CodePeer or
+ -- GNATprove.
if VM_Target = No_VM
and then not CodePeer_Mode
+ and then not ALFA_Mode
and then Exception_Mechanism = Back_End_Exceptions
then
return;
-- Start of processing for Expand_N_Protected_Type_Declaration
begin
- -- Do not expand tasking constructs in formal verification mode
-
- if ALFA_Mode then
- return;
- end if;
-
if Present (Corresponding_Record_Type (Prot_Typ)) then
return;
else
-- Note: we inhibit this check for objects that do not come
-- from source because there is at least one case (the
- -- expansion of x'class'input where x is abstract) where we
+ -- expansion of x'Class'Input where x is abstract) where we
-- legitimately generate an abstract object.
if Is_Abstract_Type (Etype (E))
-- package Pkg is
-- type T is tagged private;
-- type DT is new T with private;
- -- procedure Prim (X : in out T; Y : in out DT'class);
+ -- procedure Prim (X : in out T; Y : in out DT'Class);
-- private
-- type T is tagged null record;
-- Obj : T;
-- indicate that the underlying tool (gnatcheck, gnatpp or gnatmetric)
-- should be invoked for all sources of all projects.
+ Max_OpenVMS_Logical_Length : constant Integer := 255;
+ -- The maximum length of OpenVMS logicals
+
-----------------------
-- Local Subprograms --
-----------------------
Add_Str_To_Name_Buffer (Argument (J));
end loop;
+ -- On OpenVMS, setenv creates a logical whose length is limited to
+ -- 255 bytes.
+
+ if OpenVMS and then Name_Len > Max_OpenVMS_Logical_Length then
+ Name_Buffer (Max_OpenVMS_Logical_Length - 2
+ .. Max_OpenVMS_Logical_Length) := "...";
+ Name_Len := Max_OpenVMS_Logical_Length;
+ end if;
+
Setenv ("GNAT_DRIVER_COMMAND_LINE", Name_Buffer (1 .. Name_Len));
-- Add the directory where the GNAT driver is invoked in front of the path,
Gnatbind_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatbind.all);
Gnatlink_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gnatlink.all);
- -- If we have specified -j switch both from the project file
- -- and on the command line, the one from the command line takes
- -- precedence.
-
- if Saved_Maximum_Processes = 0 then
- Saved_Maximum_Processes := Maximum_Processes;
- end if;
-
- if Debug.Debug_Flag_M then
- Write_Line ("Maximum number of simultaneous compilations =" &
- Saved_Maximum_Processes'Img);
- end if;
-
- -- Allocate as many temporary mapping file names as the maximum number
- -- of compilations processed, for each possible project.
-
- declare
- Data : Project_Compilation_Access;
- Proj : Project_List;
-
- begin
- Proj := Project_Tree.Projects;
- while Proj /= null loop
- Data := new Project_Compilation_Data'
- (Mapping_File_Names => new Temp_Path_Names
- (1 .. Saved_Maximum_Processes),
- Last_Mapping_File_Names => 0,
- Free_Mapping_File_Indexes => new Free_File_Indexes
- (1 .. Saved_Maximum_Processes),
- Last_Free_Indexes => 0);
-
- Project_Compilation_Htable.Set
- (Project_Compilation, Proj.Project, Data);
- Proj := Proj.Next;
- end loop;
-
- Data := new Project_Compilation_Data'
- (Mapping_File_Names => new Temp_Path_Names
- (1 .. Saved_Maximum_Processes),
- Last_Mapping_File_Names => 0,
- Free_Mapping_File_Indexes => new Free_File_Indexes
- (1 .. Saved_Maximum_Processes),
- Last_Free_Indexes => 0);
-
- Project_Compilation_Htable.Set
- (Project_Compilation, No_Project, Data);
- end;
-
Bad_Compilation.Init;
-- If project files are used, create the mapping of all the sources, so
end case;
end if;
+ -- If we have specified -j switch both from the project file
+ -- and on the command line, the one from the command line takes
+ -- precedence.
+
+ if Saved_Maximum_Processes = 0 then
+ Saved_Maximum_Processes := Maximum_Processes;
+ end if;
+
+ if Debug.Debug_Flag_M then
+ Write_Line ("Maximum number of simultaneous compilations =" &
+ Saved_Maximum_Processes'Img);
+ end if;
+
+ -- Allocate as many temporary mapping file names as the maximum
+ -- number of compilations processed, for each possible project.
+
+ declare
+ Data : Project_Compilation_Access;
+ Proj : Project_List;
+
+ begin
+ Proj := Project_Tree.Projects;
+ while Proj /= null loop
+ Data := new Project_Compilation_Data'
+ (Mapping_File_Names => new Temp_Path_Names
+ (1 .. Saved_Maximum_Processes),
+ Last_Mapping_File_Names => 0,
+ Free_Mapping_File_Indexes => new Free_File_Indexes
+ (1 .. Saved_Maximum_Processes),
+ Last_Free_Indexes => 0);
+
+ Project_Compilation_Htable.Set
+ (Project_Compilation, Proj.Project, Data);
+ Proj := Proj.Next;
+ end loop;
+
+ Data := new Project_Compilation_Data'
+ (Mapping_File_Names => new Temp_Path_Names
+ (1 .. Saved_Maximum_Processes),
+ Last_Mapping_File_Names => 0,
+ Free_Mapping_File_Indexes => new Free_File_Indexes
+ (1 .. Saved_Maximum_Processes),
+ Last_Free_Indexes => 0);
+
+ Project_Compilation_Htable.Set
+ (Project_Compilation, No_Project, Data);
+ end;
+
Is_First_Main := False;
end if;
then
return True;
+ elsif From_With_Type (T1)
+ and then From_With_Type (T2)
+ and then Available_View (T1) = Available_View (T2)
+ then
+ return True;
+
else
return False;
end if;
Result := Defining_Entity (New_Decl);
end if;
- -- Return the class-wide operation if one was created.
+ -- Return the class-wide operation if one was created
return Result;
end Check_Class_Wide_Actual;
-- If this a defaulted subprogram for a class-wide actual there is
-- no check for mode conformance, given that the signatures don't
- -- match (the source mentions T but the actual mentions T'class).
+ -- match (the source mentions T but the actual mentions T'Class).
if CW_Actual then
null;
Next_Entity (Id);
end loop;
- -- If not found, standard error message.
+ -- If not found, standard error message
Error_Msg_NE ("& not declared in&", N, Selector);
It1 : Interp;
Seen : Entity_Id := Empty; -- prevent junk warning
- procedure Build_Explicit_Dereference
- (Expr : Node_Id;
- Disc : Entity_Id);
- -- AI05-139: Names with implicit dereference. If the expression N is a
- -- reference type and the context imposes the corresponding designated
- -- type, convert N into N.Disc.all. Such expressions are always over-
- -- loaded with both interpretations, and the dereference interpretation
- -- carries the name of the reference discriminant.
-
function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean;
-- Determine whether a node comes from a predefined library unit or
-- Standard.
procedure Resolution_Failed;
-- Called when attempt at resolving current expression fails
- --------------------------------
- -- Build_Explicit_Dereference --
- --------------------------------
-
- procedure Build_Explicit_Dereference
- (Expr : Node_Id;
- Disc : Entity_Id)
- is
- Loc : constant Source_Ptr := Sloc (Expr);
-
- begin
- Set_Is_Overloaded (Expr, False);
- Rewrite (Expr,
- Make_Explicit_Dereference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => Relocate_Node (Expr),
- Selector_Name => New_Occurrence_Of (Disc, Loc))));
-
- Set_Etype (Prefix (Expr), Etype (Disc));
- Set_Etype (Expr, Typ);
- end Build_Explicit_Dereference;
-
------------------------------------
-- Comes_From_Predefined_Lib_Unit --
-------------------------------------
Set_Has_Fully_Qualified_Name (Elab_Ent);
end Build_Elaboration_Entity;
+ --------------------------------
+ -- Build_Explicit_Dereference --
+ --------------------------------
+
+ procedure Build_Explicit_Dereference
+ (Expr : Node_Id;
+ Disc : Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Expr);
+
+ begin
+ Set_Is_Overloaded (Expr, False);
+ Rewrite (Expr,
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => Relocate_Node (Expr),
+ Selector_Name =>
+ New_Occurrence_Of (Disc, Loc))));
+
+ Set_Etype (Prefix (Expr), Etype (Disc));
+ Set_Etype (Expr, Designated_Type (Etype (Disc)));
+ end Build_Explicit_Dereference;
+
-----------------------------------
-- Cannot_Raise_Constraint_Error --
-----------------------------------
end if;
end Is_Fully_Initialized_Variant;
+ -----------------
+ -- Is_Iterator --
+ -----------------
+
+ function Is_Iterator (Typ : Entity_Id) return Boolean is
+ Ifaces_List : Elist_Id;
+ Iface_Elmt : Elmt_Id;
+ Iface : Entity_Id;
+
+ begin
+ if 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_Forward_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;
+
+ return False;
+ 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 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 --
------------
-- original node is a conversion, then Is_Variable will not be true
-- but we still want to allow the conversion if it converts a variable).
+ -- In Ada2012, the explicit dereference may be a rewritten call
+ -- to a Reference function.
+
elsif Original_Node (AV) /= AV then
- return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
+ if Ada_Version >= Ada_2012
+ and then Nkind (Original_Node (AV)) = N_Function_Call
+ and then
+ Has_Implicit_Dereference
+ (Etype (Name (Original_Node (AV))))
+ then
+ return True;
+
+ else
+ return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
+ end if;
-- All other non-variables are rejected
-- the compilation unit, and install it in the Elaboration_Entity field
-- of Spec_Id, the entity for the compilation unit.
+ procedure Build_Explicit_Dereference
+ (Expr : Node_Id;
+ Disc : Entity_Id);
+ -- AI05-139: Names with implicit dereference. If the expression N is a
+ -- reference type and the context imposes the corresponding designated
+ -- type, convert N into N.Disc.all. Such expressions are always over-
+ -- loaded with both interpretations, and the dereference interpretation
+ -- carries the name of the reference discriminant.
+
function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean;
-- Returns True if the expression cannot possibly raise Constraint_Error.
-- The response is conservative in the sense that a result of False does
-- E is a subprogram. Return True is E is an implicit operation inherited
-- by the derived type declaration for type Typ.
+ function Is_Iterator (Typ : Entity_Id) return Boolean;
+ -- AI05-0139-2 : check whether Typ is derived from the predefined interface
+ -- Ada.Iterator_Interfaces.Forward_Iterator.
+
+ function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean;
+ -- Ditto for Ada.Iterator_Interfaces.Reversible_Iterator.
+
function Is_LHS (N : Node_Id) return Boolean;
-- Returns True iff N is used as Name in an assignment statement
Name_Cursor : constant Name_Id := N + $;
Name_Element : constant Name_Id := N + $;
Name_Element_Type : constant Name_Id := N + $;
+ Name_Has_Element : constant Name_Id := N + $;
Name_No_Element : constant Name_Id := N + $;
+ Name_Forward_Iterator : constant Name_Id := N + $;
+ Name_Reversible_Iterator : constant Name_Id := N + $;
Name_Previous : constant Name_Id := N + $;
-- Ada 2005 reserved words
projects / platform / upstream / gcc.git / commitdiff