From 7134062aa9c1264d1dd9f1aca0a433f3586b79c9 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 29 Aug 2011 14:21:49 +0200 Subject: [PATCH] [multiple changes] 2011-08-29 Robert Dewar * sem_ch6.adb, exp_ch3.adb, s-stposu.adb, a-undesu.ads, a-undesu.adb: Minor reformatting. 2011-08-29 Ed Schonberg * 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. From-SVN: r178211 --- gcc/ada/ChangeLog | 17 +++++ gcc/ada/a-convec.adb | 164 +++++++++++++++++++++++++++++++++++++++++-- gcc/ada/a-convec.ads | 125 +++++++++++++++++++++++++-------- gcc/ada/a-iteint.ads | 39 ++++++---- gcc/ada/a-undesu.adb | 24 +++++-- gcc/ada/a-undesu.ads | 4 -- gcc/ada/exp_ch3.adb | 2 +- gcc/ada/exp_disp.adb | 42 +++++++++++ gcc/ada/s-stposu.adb | 6 +- gcc/ada/sem_ch6.adb | 2 +- 10 files changed, 359 insertions(+), 66 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 75f4d4e7d056..53f5eee019e3 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,20 @@ +2011-08-29 Robert Dewar + + * sem_ch6.adb, exp_ch3.adb, s-stposu.adb, a-undesu.ads, + a-undesu.adb: Minor reformatting. + +2011-08-29 Ed Schonberg + + * 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 * a-exexpr-gcc.adb, a-synbar.adb, sem_ch13.adb: Minor reformatting. diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index 6a3d186a200c..c9c022d26a40 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -37,6 +37,19 @@ package body Ada.Containers.Vectors is 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; + --------- -- "&" -- --------- @@ -786,6 +799,12 @@ package body Ada.Containers.Vectors is 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 -- ------------------- @@ -937,11 +956,7 @@ package body Ada.Containers.Vectors is 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; ------------ @@ -2018,6 +2033,23 @@ package body Ada.Containers.Vectors is 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 -- ---------- @@ -2031,6 +2063,12 @@ package body Ada.Containers.Vectors is 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 -- ------------------ @@ -2138,6 +2176,17 @@ package body Ada.Containers.Vectors is 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 -- ---------- @@ -2206,6 +2255,16 @@ package body Ada.Containers.Vectors is 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 -- ------------------- @@ -2287,6 +2346,83 @@ package body Ada.Containers.Vectors is 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 -- --------------------- @@ -3117,4 +3253,20 @@ package body Ada.Containers.Vectors is 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; diff --git a/gcc/ada/a-convec.ads b/gcc/ada/a-convec.ads index 71276eba61ec..b185a743b1b3 100644 --- a/gcc/ada/a-convec.ads +++ b/gcc/ada/a-convec.ads @@ -32,8 +32,8 @@ ------------------------------------------------------------------------------ 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; @@ -43,6 +43,7 @@ generic 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 .. @@ -50,15 +51,35 @@ package Ada.Containers.Vectors is 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; @@ -133,8 +154,55 @@ package Ada.Containers.Vectors is 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; @@ -278,8 +346,6 @@ package Ada.Containers.Vectors is (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)); @@ -288,6 +354,12 @@ package Ada.Containers.Vectors is (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 @@ -315,7 +387,7 @@ private 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 @@ -333,11 +405,13 @@ private 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; @@ -351,28 +425,17 @@ private 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; diff --git a/gcc/ada/a-iteint.ads b/gcc/ada/a-iteint.ads index 99dd304a4e9e..c6aaa768147d 100644 --- a/gcc/ada/a-iteint.ads +++ b/gcc/ada/a-iteint.ads @@ -6,32 +6,45 @@ -- -- -- 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 -- +-- . -- -- -- ------------------------------------------------------------------------------ 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; diff --git a/gcc/ada/a-undesu.adb b/gcc/ada/a-undesu.adb index 14c60aac50b7..d2bd292e1458 100644 --- a/gcc/ada/a-undesu.adb +++ b/gcc/ada/a-undesu.adb @@ -8,15 +8,27 @@ -- -- -- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/a-undesu.ads b/gcc/ada/a-undesu.ads index b59888247aec..666572530dd2 100644 --- a/gcc/ada/a-undesu.ads +++ b/gcc/ada/a-undesu.ads @@ -6,8 +6,6 @@ -- -- -- 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 -- @@ -15,8 +13,6 @@ -- -- ------------------------------------------------------------------------------ --- ??? What is the header version here, see a-uncdea.ads. No GPL? - with System.Storage_Pools.Subpools; procedure Ada.Unchecked_Deallocate_Subpool diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index a22f86dff88c..a7d382bf3d7a 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -5483,7 +5483,7 @@ package body Exp_Ch3 is 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)) diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index e7614aa8ac1f..3df1224e92b5 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -3698,6 +3698,46 @@ package body Exp_Disp is 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) @@ -3720,6 +3760,8 @@ package body Exp_Disp is 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; diff --git a/gcc/ada/s-stposu.adb b/gcc/ada/s-stposu.adb index e7436c6088f0..e1ec4239e2e0 100644 --- a/gcc/ada/s-stposu.adb +++ b/gcc/ada/s-stposu.adb @@ -8,10 +8,6 @@ -- -- -- 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- -- @@ -259,6 +255,7 @@ package body System.Storage_Pools.Subpools is -- object. This operation effectively hides the list header. Addr := N_Addr + Header_And_Padding; + else Addr := N_Addr; end if; @@ -346,6 +343,7 @@ package body System.Storage_Pools.Subpools is -- hidden list header. N_Size := Storage_Size + Header_And_Padding; + else N_Addr := Addr; N_Size := Storage_Size; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index b8fd3e7533fc..165ce9f849bd 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -2348,7 +2348,7 @@ package body Sem_Ch6 is -- 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. -- 2.43.5