diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 56 | ||||
| -rw-r--r-- | gcc/ada/a-cdlili.adb | 122 | ||||
| -rw-r--r-- | gcc/ada/a-cdlili.ads | 77 | ||||
| -rw-r--r-- | gcc/ada/a-chtgbo.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/a-cohama.adb | 88 | ||||
| -rw-r--r-- | gcc/ada/a-cohama.ads | 93 | ||||
| -rw-r--r-- | gcc/ada/a-coinve.adb | 155 | ||||
| -rw-r--r-- | gcc/ada/a-coinve.ads | 104 | ||||
| -rw-r--r-- | gcc/ada/a-convec.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/a-convec.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/a-coorse.adb | 121 | ||||
| -rw-r--r-- | gcc/ada/a-coorse.ads | 99 | ||||
| -rwxr-xr-x | gcc/ada/aspects.adb | 27 | ||||
| -rwxr-xr-x | gcc/ada/aspects.ads | 3 | ||||
| -rw-r--r-- | gcc/ada/exp_ch11.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/exp_ch9.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/gnatcmd.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/make.adb | 96 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 32 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 112 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 16 | ||||
| -rw-r--r-- | gcc/ada/snames.ads-tmpl | 3 |
25 files changed, 1092 insertions, 166 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6d02bc6dd38..1ba297ce24d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,59 @@ +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. diff --git a/gcc/ada/a-cdlili.adb b/gcc/ada/a-cdlili.adb index cbac8fd4a1d..8a3b98358dd 100644 --- a/gcc/ada/a-cdlili.adb +++ b/gcc/ada/a-cdlili.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- -- @@ -32,6 +32,18 @@ with System; use type System.Address; 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 -- @@ -395,6 +407,12 @@ package body Ada.Containers.Doubly_Linked_Lists is 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 -- ------------------- @@ -794,6 +812,22 @@ package body Ada.Containers.Doubly_Linked_Lists is 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 -- ---------- @@ -807,6 +841,12 @@ package body Ada.Containers.Doubly_Linked_Lists is 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 -- ------------------ @@ -887,6 +927,16 @@ package body Ada.Containers.Doubly_Linked_Lists is 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 -- ------------- @@ -928,6 +978,16 @@ package body Ada.Containers.Doubly_Linked_Lists is 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 -- ------------------- @@ -1027,6 +1087,50 @@ package body Ada.Containers.Doubly_Linked_Lists is 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 -- --------------------- @@ -1832,4 +1936,20 @@ package body Ada.Containers.Doubly_Linked_Lists is 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; diff --git a/gcc/ada/a-cdlili.ads b/gcc/ada/a-cdlili.ads index 30e37085427..8b3a16abbf6 100644 --- a/gcc/ada/a-cdlili.ads +++ b/gcc/ada/a-cdlili.ads @@ -6,7 +6,7 @@ -- -- -- 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 -- @@ -32,7 +32,8 @@ ------------------------------------------------------------------------------ private with Ada.Finalization; -private with Ada.Streams; +with Ada.Streams; use Ada.Streams; +with Ada.Iterator_Interfaces; generic type Element_Type is private; @@ -44,7 +45,13 @@ package Ada.Containers.Doubly_Linked_Lists is 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; @@ -53,6 +60,10 @@ package Ada.Containers.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 + Ada.Iterator_Interfaces (Cursor, Has_Element); function "=" (Left, Right : List) return Boolean; @@ -126,6 +137,12 @@ package Ada.Containers.Doubly_Linked_Lists is 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); @@ -180,8 +197,6 @@ package Ada.Containers.Doubly_Linked_Lists is (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)); @@ -202,6 +217,48 @@ package Ada.Containers.Doubly_Linked_Lists is 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); @@ -212,7 +269,7 @@ private type Node_Type is limited record - Element : Element_Type; + Element : aliased Element_Type; Next : Node_Access; Prev : Node_Access; end record; @@ -232,8 +289,6 @@ private 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); @@ -267,6 +322,12 @@ private 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); diff --git a/gcc/ada/a-chtgbo.adb b/gcc/ada/a-chtgbo.adb index b19668e1391..fce5dd21a01 100644 --- a/gcc/ada/a-chtgbo.adb +++ b/gcc/ada/a-chtgbo.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- -- @@ -296,7 +296,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is -- 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; @@ -314,7 +314,7 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is 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 diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb index 65247241939..fdf9696fd61 100644 --- a/gcc/ada/a-cohama.adb +++ b/gcc/ada/a-cohama.adb @@ -37,6 +37,16 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); 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 -- ----------------------- @@ -362,6 +372,17 @@ package body Ada.Containers.Hashed_Maps is 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 -- ---------- @@ -578,6 +599,15 @@ package body Ada.Containers.Hashed_Maps is 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 -- --------- @@ -650,6 +680,16 @@ package body Ada.Containers.Hashed_Maps is 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 -- ------------------- @@ -716,6 +756,38 @@ package body Ada.Containers.Hashed_Maps is 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 -- --------------- @@ -939,6 +1011,22 @@ package body Ada.Containers.Hashed_Maps is 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 -- ---------------- diff --git a/gcc/ada/a-cohama.ads b/gcc/ada/a-cohama.ads index 9c00c6e4f37..2ade56e1952 100644 --- a/gcc/ada/a-cohama.ads +++ b/gcc/ada/a-cohama.ads @@ -6,7 +6,7 @@ -- -- -- 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 -- @@ -32,8 +32,9 @@ ------------------------------------------------------------------------------ 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; @@ -47,12 +48,30 @@ package Ada.Containers.Hashed_Maps is 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. @@ -61,6 +80,12 @@ package Ada.Containers.Hashed_Maps is -- 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 @@ -235,9 +260,6 @@ package Ada.Containers.Hashed_Maps is 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. @@ -250,11 +272,54 @@ package Ada.Containers.Hashed_Maps is -- 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); @@ -293,8 +358,6 @@ private overriding procedure Finalize (Container : in out Map); - use Ada.Streams; - procedure Write (Stream : not null access Root_Stream_Type'Class; Container : Map); @@ -315,17 +378,11 @@ private 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)); diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index c6f8cb26325..fa90aaf31f5 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.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- -- @@ -39,6 +39,19 @@ package body Ada.Containers.Indefinite_Vectors is 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; + --------- -- "&" -- --------- @@ -1075,6 +1088,12 @@ package body Ada.Containers.Indefinite_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 -- ------------------- @@ -2406,6 +2425,23 @@ package body Ada.Containers.Indefinite_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.Reversible_Iterator'class + is + It : constant Iterator := + (Container'Unchecked_Access, Start.Index); + begin + return It; + end Iterate; + ---------- -- Last -- ---------- @@ -2419,6 +2455,12 @@ package body Ada.Containers.Indefinite_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 -- ------------------ @@ -2533,6 +2575,15 @@ package body Ada.Containers.Indefinite_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 -- ---------- @@ -2601,6 +2652,15 @@ package body Ada.Containers.Indefinite_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 -- ------------------- @@ -2695,6 +2755,83 @@ package body Ada.Containers.Indefinite_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).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 -- --------------------- @@ -3579,4 +3716,20 @@ package body Ada.Containers.Indefinite_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.Indefinite_Vectors; diff --git a/gcc/ada/a-coinve.ads b/gcc/ada/a-coinve.ads index a8e8af21bd0..866beb9c55f 100644 --- a/gcc/ada/a-coinve.ads +++ b/gcc/ada/a-coinve.ads @@ -6,7 +6,7 @@ -- -- -- 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 -- @@ -32,7 +32,8 @@ ------------------------------------------------------------------------------ private with Ada.Finalization; -private with Ada.Streams; +with Ada.Streams; use Ada.Streams; +with Ada.Iterator_Interfaces; generic type Index_Type is range <>; @@ -50,7 +51,13 @@ package Ada.Containers.Indefinite_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; @@ -59,6 +66,22 @@ package Ada.Containers.Indefinite_Vectors is 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; @@ -92,6 +115,53 @@ package Ada.Containers.Indefinite_Vectors is 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; @@ -267,12 +337,16 @@ package Ada.Containers.Indefinite_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)); + 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)); @@ -323,12 +397,16 @@ private 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); @@ -349,18 +427,6 @@ private 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); diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index f61809adf40..3587b2d06af 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -2034,7 +2034,7 @@ package body Ada.Containers.Vectors is 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 @@ -2042,7 +2042,7 @@ package body Ada.Containers.Vectors is 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); diff --git a/gcc/ada/a-convec.ads b/gcc/ada/a-convec.ads index b185a743b1b..bf9a0d42e01 100644 --- a/gcc/ada/a-convec.ads +++ b/gcc/ada/a-convec.ads @@ -6,7 +6,7 @@ -- -- -- 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 -- @@ -355,10 +355,10 @@ package Ada.Containers.Vectors is 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 <>; diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb index d4e73029b2a..2224fdf317e 100644 --- a/gcc/ada/a-coorse.adb +++ b/gcc/ada/a-coorse.adb @@ -40,6 +40,19 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); 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 -- ------------------------------ @@ -512,6 +525,12 @@ package body Ada.Containers.Ordered_Sets is 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 -- ------------------- @@ -1115,6 +1134,23 @@ package body Ada.Containers.Ordered_Sets is 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 -- ---------- @@ -1128,6 +1164,16 @@ package body Ada.Containers.Ordered_Sets is 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 -- ------------------ @@ -1202,6 +1248,14 @@ package body Ada.Containers.Ordered_Sets is Position := Next (Position); end Next; + function Next (Object : Iterator; Position : Cursor) + return Cursor + is + pragma Unreferenced (Object); + begin + return Next (Position); + end Next; + ------------- -- Overlap -- ------------- @@ -1251,6 +1305,13 @@ package body Ada.Containers.Ordered_Sets is 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 -- ------------------- @@ -1339,6 +1400,50 @@ package body Ada.Containers.Ordered_Sets is 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 -- ------------- @@ -1654,4 +1759,20 @@ package body Ada.Containers.Ordered_Sets is 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; diff --git a/gcc/ada/a-coorse.ads b/gcc/ada/a-coorse.ads index afa767159cd..cf52da66a1c 100644 --- a/gcc/ada/a-coorse.ads +++ b/gcc/ada/a-coorse.ads @@ -33,7 +33,8 @@ 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; @@ -47,16 +48,81 @@ package Ada.Containers.Ordered_Sets is 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; @@ -168,8 +234,6 @@ package Ada.Containers.Ordered_Sets is 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; @@ -190,6 +254,12 @@ package Ada.Containers.Ordered_Sets is (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; @@ -243,7 +313,7 @@ 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 @@ -260,7 +330,6 @@ private 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; @@ -270,18 +339,6 @@ private 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 @@ -296,6 +353,12 @@ private 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, diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index 43d0df600c2..f2159db7291 100755 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -30,6 +30,7 @@ ------------------------------------------------------------------------------ with Atree; use Atree; +with Einfo; use Einfo; with Nlists; use Nlists; with Sinfo; use Sinfo; with Tree_IO; use Tree_IO; @@ -118,6 +119,32 @@ package body Aspects is 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 -- ------------------ diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index ee992a6383f..b355cadc17d 100755 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -359,6 +359,9 @@ package Aspects is -- 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. diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 5238a1c7c0c..8b391d5e80a 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1666,10 +1666,12 @@ package body Exp_Ch11 is 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; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 9ec2e441c73..b57f3d62e65 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -7930,12 +7930,6 @@ package body Exp_Ch9 is -- 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 diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 7fae15526cb..4862518137c 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -2820,7 +2820,7 @@ package body Freeze is -- 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)) @@ -3712,7 +3712,7 @@ package body Freeze is -- 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; diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index ec9c4e97b44..051082f640f 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -202,6 +202,9 @@ procedure GNATCmd is -- 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 -- ----------------------- @@ -1420,6 +1423,15 @@ begin 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, diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 3cf73c8e449..ce12020bc04 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -5977,54 +5977,6 @@ package body Make is 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 @@ -6126,6 +6078,54 @@ package body Make is 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; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index afd03c2d51f..877e8b8f7e2 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -5669,6 +5669,12 @@ package body Sem_Ch6 is 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; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 46bdf73ab0d..87d5717f41a 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -1834,7 +1834,7 @@ package body Sem_Ch8 is 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; @@ -2482,7 +2482,7 @@ package body Sem_Ch8 is -- 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; @@ -5141,7 +5141,7 @@ package body Sem_Ch8 is 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); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index f56b849cbed..86c6d3e4156 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -1754,15 +1754,6 @@ package body Sem_Res is 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. @@ -1778,29 +1769,6 @@ package body Sem_Res is 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 -- ------------------------------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 814eaa4e965..f6088afc9d6 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -981,6 +981,30 @@ package body Sem_Util is 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 -- ----------------------------------- @@ -7144,6 +7168,79 @@ package body Sem_Util is 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 -- ------------ @@ -7369,8 +7466,21 @@ package body Sem_Util is -- 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 diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index bc36fb228f0..89ae19819ae 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -141,6 +141,15 @@ package Sem_Util is -- 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 @@ -799,6 +808,13 @@ package Sem_Util is -- 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 diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index fbe0584f140..3c54e8a05fb 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -1219,7 +1219,10 @@ package Snames is 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 |
