+2011-08-29 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch6.adb, exp_ch3.adb, s-stposu.adb, a-undesu.ads,
+ a-undesu.adb: Minor reformatting.
+
+2011-08-29 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_disp.adb (Check_Premature_Freezing): When building a dispatch
+ table, accept an unfrozen untagged component if it is an actual for a
+ formal incomplete type.
+ * a-convec.ads, a-convec.adb: Instantiate Ada.Iterator_Interfaces to
+ provide new iterator forms over vectors.
+ Introduce type Iterator in package body to implement operations of
+ Reversible_Iterator interface.
+ * a-iteint.ads: Make package pure so it is usable with new container
+ packages, that are categorized Remote_Types.
+
2011-08-29 Robert Dewar <dewar@adacore.com>
* a-exexpr-gcc.adb, a-synbar.adb, sem_ch13.adb: Minor reformatting.
-- --
-- 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 (Elements_Type, Elements_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 --
-------------------
function Has_Element (Position : Cursor) return Boolean is
begin
- if Position.Container = null then
- return False;
- end if;
-
- return Position.Index <= Position.Container.Last;
+ return Position /= No_Element;
end Has_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.Forward_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)'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)'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)'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)'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.Vectors;
------------------------------------------------------------------------------
private with Ada.Finalization;
-private with Ada.Streams;
-
+with Ada.Streams;
+with Ada.Iterator_Interfaces;
generic
type Index_Type is range <>;
type Element_Type is private;
package Ada.Containers.Vectors is
pragma Preelaborate;
pragma Remote_Types;
+ use Ada.Streams;
subtype Extended_Index is Index_Type'Base
range Index_Type'First - 1 ..
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;
pragma Preelaborable_Initialization (Cursor);
+ No_Element : constant Cursor;
- Empty_Vector : constant Vector;
+ function Has_Element (Position : Cursor) return Boolean;
- No_Element : constant Cursor;
+ 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);
+
+ Empty_Vector : constant Vector;
overriding function "=" (Left, Right : Vector) return Boolean;
Position : Cursor;
Process : not null access procedure (Element : in out Element_Type));
- procedure Move (Target : in out Vector; Source : 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;
+
+ procedure Move (Target : in out Vector; Source : in out Vector);
procedure Insert
(Container : in out Vector;
Before : Extended_Index;
(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));
(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.Forward_Iterator'class;
+
generic
with function "<" (Left, Right : Element_Type) return Boolean is <>;
package Generic_Sorting is
pragma Inline (Next);
pragma Inline (Previous);
- type Elements_Array is array (Index_Type range <>) of Element_Type;
+ type Elements_Array is array (Index_Type range <>) of aliased Element_Type;
function "=" (L, R : Elements_Array) return Boolean is abstract;
type Elements_Type (Last : Index_Type) is limited record
Lock : Natural := 0;
end record;
- overriding procedure Adjust (Container : in out Vector);
-
- overriding procedure Finalize (Container : in out Vector);
+ type Vector_Access is access constant Vector;
+ for Vector_Access'Storage_Size use 0;
- use Ada.Streams;
+ type Cursor is record
+ Container : Vector_Access;
+ Index : Index_Type := Index_Type'First;
+ end record;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
for Vector'Read use Read;
- type Vector_Access is access constant Vector;
- for Vector_Access'Storage_Size use 0;
-
- type Cursor is record
- Container : Vector_Access;
- Index : Index_Type := Index_Type'First;
- end record;
-
- procedure Write
- (Stream : not null access Root_Stream_Type'Class;
- Position : Cursor);
+ type Constant_Reference_Type
+ (Element : not null access constant Element_Type) is null record;
- for Cursor'Write use Write;
+ type Reference_Type
+ (Element : not null access Element_Type) is null record;
- procedure Read
- (Stream : not null access Root_Stream_Type'Class;
- Position : out Cursor);
+ overriding procedure Adjust (Container : in out Vector);
- for Cursor'Read use Read;
+ overriding procedure Finalize (Container : in out Vector);
+ No_Element : constant Cursor := Cursor'(null, Index_Type'First);
Empty_Vector : constant Vector := (Controlled with null, No_Index, 0, 0);
- No_Element : constant Cursor := Cursor'(null, Index_Type'First);
-
end Ada.Containers.Vectors;
-- --
-- S p e c --
-- --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
+-- --
-- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. In accordance with the copyright of that document, you can freely --
--- copy and modify this specification, provided that if you redistribute a --
--- modified version, any changes that you have made are clearly indicated. --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- 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- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
-- --
------------------------------------------------------------------------------
generic
- type Cursor is private;
- No_Element : Cursor;
- pragma Unreferenced (No_Element);
-
+ type Cursor;
+ with function Has_Element (Position : Cursor) return Boolean;
package Ada.Iterator_Interfaces is
- type Forward_Iterator is limited interface;
+ pragma Pure;
+ type Forward_Iterator is limited interface;
function First (Object : Forward_Iterator) return Cursor is abstract;
-
function Next
- (Object : Forward_Iterator;
+ (Object : Forward_Iterator;
Position : Cursor) return Cursor is abstract;
-
type Reversible_Iterator is limited interface and Forward_Iterator;
function Last (Object : Reversible_Iterator) return Cursor is abstract;
-
function Previous
- (Object : Reversible_Iterator;
+ (Object : Reversible_Iterator;
Position : Cursor) return Cursor is abstract;
end Ada.Iterator_Interfaces;
-- --
-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. In accordance with the copyright of that document, you can freely --
--- copy and modify this specification, provided that if you redistribute a --
--- modified version, any changes that you have made are clearly indicated. --
+-- 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- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
--- ??? What is the header version here, see a-uncdea.adb. No GPL?
-
with System.Storage_Pools.Subpools,
System.Storage_Pools.Subpools.Finalization;
-- --
-- S p e c --
-- --
--- Copyright (C) 2011, Free Software Foundation, Inc. --
--- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- --
------------------------------------------------------------------------------
--- ??? What is the header version here, see a-uncdea.ads. No GPL?
-
with System.Storage_Pools.Subpools;
procedure Ada.Unchecked_Deallocate_Subpool
end if;
-- ??? Now that masters acts as heterogeneous lists, it might be
- -- worthed to revisit the global master approach.
+ -- worthwhile to revisit the global master approach.
elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type
and then Needs_Finalization (Directly_Designated_Type (Comp_Typ))
Typ : Entity_Id)
is
Comp : Entity_Id;
+ function Is_Actual_For_Formal_Incomplete_Type (T : Entity_Id)
+ return Boolean;
+ -- In Ada2012, if a nested generic has an incomplete formal type, the
+ -- actual may be (and usually is) a private type whose completion
+ -- appears later. It is safe to build the dispatch table in this
+ -- case, gigi will have full views available.
+
+ ------------------------------------------
+ -- Is_Actual_For_Formal_Incomplete_Type --
+ ------------------------------------------
+
+ function Is_Actual_For_Formal_Incomplete_Type (T : Entity_Id)
+ return Boolean
+ is
+ Gen_Par : Entity_Id;
+ F : Node_Id;
+ begin
+ if not Is_Generic_Instance (Current_Scope)
+ or else not Used_As_Generic_Actual (T)
+ then
+ return False;
+
+ else
+ Gen_Par := Generic_Parent (Parent (Current_Scope));
+ end if;
+
+ F :=
+ First
+ (Generic_Formal_Declarations
+ (Unit_Declaration_Node (Gen_Par)));
+ while Present (F) loop
+ if Ekind (Defining_Identifier (F)) = E_Incomplete_Type then
+ return True;
+ end if;
+
+ Next (F);
+ end loop;
+
+ return False;
+ end Is_Actual_For_Formal_Incomplete_Type;
begin
if Present (N)
if not Is_Tagged_Type (Typ)
and then Present (Comp)
and then not Is_Frozen (Comp)
+ and then
+ not Is_Actual_For_Formal_Incomplete_Type (Comp)
then
Error_Msg_Sloc := Sloc (Subp);
Error_Msg_Node_2 := Subp;
-- --
-- Copyright (C) 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 --
--- apply solely to the contents of the part following the private keyword. --
--- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- object. This operation effectively hides the list header.
Addr := N_Addr + Header_And_Padding;
+
else
Addr := N_Addr;
end if;
-- hidden list header.
N_Size := Storage_Size + Header_And_Padding;
+
else
N_Addr := Addr;
N_Size := Storage_Size;
-- the proper back-annotations.
if not Is_Frozen (Spec_Id)
- and then (Expander_Active or else ASIS_Mode)
+ and then (Expander_Active or ASIS_Mode)
then
-- Force the generation of its freezing node to ensure proper
-- management of access types in the backend.
projects / thirdparty / gcc.git / commitdiff
