diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 35 | ||||
| -rw-r--r-- | gcc/ada/a-cidlli.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/a-cihama.adb | 19 | ||||
| -rw-r--r-- | gcc/ada/a-cihase.adb | 28 | ||||
| -rw-r--r-- | gcc/ada/a-cimutr.adb | 45 | ||||
| -rw-r--r-- | gcc/ada/a-ciorma.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/a-ciormu.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/a-ciorse.adb | 57 | ||||
| -rw-r--r-- | gcc/ada/a-coinho.adb | 21 | ||||
| -rw-r--r-- | gcc/ada/a-coinve.adb | 56 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 118 | ||||
| -rw-r--r-- | gcc/ada/par-ch6.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/projects.texi | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 36 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 31 |
15 files changed, 438 insertions, 66 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index eda6cbb64ec..c504dea1af2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,38 @@ +2012-07-23 Ed Schonberg <schonberg@adacore.com> + + * par-ch6.adb (P_Mode): in Ada 2005, a mode indicator can apply + to a formal object of an anonymous access type. + +2012-07-23 Ed Schonberg <schonberg@adacore.com> + + * sem_ch4.adb (Try_Container_Indexing): A user-defined indexing + aspect can have more than one index, e.g. to describe indexing + of a multidimensional object. + +2012-07-23 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch4.adb (Apply_Accessibility_Check): Reimplemented. The check is + now more complex and contains optional finalization part and mandatory + deallocation part. + +2012-07-23 Gary Dismukes <dismukes@adacore.com> + + * a-cihama.adb, a-cihase.adb, a-cimutr.adb, a-ciorma.adb, a-ciormu.adb, + a-ciorse.adb, a-coinho.adb, a-coinve.adb, a-cidlli.adb: Unsuppress + Accessibility_Check for Element_Type allocators. + +2012-07-23 Vasiliy Fofanov <fofanov@adacore.com> + + * projects.texi: Fix typo. + +2012-07-23 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve_Explicit_Derenference): If prefix is + overloaded, remove those interpretations whose designated type + does not match the context, to avoid spurious ambiguities that + may be caused by the Ada 2012 conversion rule for anonymous + access types. + 2012-07-23 Vincent Celier <celier@adacore.com> * g-spitbo.adb (Substr (String)): Return full string and do not diff --git a/gcc/ada/a-cidlli.adb b/gcc/ada/a-cidlli.adb index cc93b4c2fc0..12a825a8d21 100644 --- a/gcc/ada/a-cidlli.adb +++ b/gcc/ada/a-cidlli.adb @@ -888,6 +888,13 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end if; declare + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the + -- allocator in the loop below, because the one in this block would + -- have failed already. + Element : Element_Access := new Element_Type'(New_Item); begin New_Node := new Node_Type'(Element, null, null); @@ -1461,8 +1468,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Assert (Vet (Position), "bad cursor in Replace_Element"); declare - X : Element_Access := Position.Node.Element; + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + X : Element_Access := Position.Node.Element; begin Position.Node.Element := new Element_Type'(New_Item); Free (X); diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb index 1d30d0443e4..3f5b7ec5bd8 100644 --- a/gcc/ada/a-cihama.adb +++ b/gcc/ada/a-cihama.adb @@ -694,6 +694,11 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Position.Node.Key := new Key_Type'(Key); + declare + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). begin Position.Node.Element := new Element_Type'(New_Item); exception @@ -731,6 +736,11 @@ package body Ada.Containers.Indefinite_Hashed_Maps is K : Key_Access := new Key_Type'(Key); E : Element_Access; + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + begin E := new Element_Type'(New_Item); return new Node_Type'(K, E, Next); @@ -1166,6 +1176,11 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Node.Key := new Key_Type'(Key); + declare + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). begin Node.Element := new Element_Type'(New_Item); exception @@ -1215,6 +1230,10 @@ package body Ada.Containers.Indefinite_Hashed_Maps is declare X : Element_Access := Position.Node.Element; + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). begin Position.Node.Element := new Element_Type'(New_Item); Free_Element (X); diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb index 735179415c1..034cfce67ec 100644 --- a/gcc/ada/a-cihase.adb +++ b/gcc/ada/a-cihase.adb @@ -185,6 +185,11 @@ package body Ada.Containers.Indefinite_Hashed_Sets is procedure Assign (Node : Node_Access; Item : Element_Type) is X : Element_Access := Node.Element; + + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the case the + -- actual type is class-wide or has access discriminants (RM 4.8(10.1) + -- and AI12-0035). begin Node.Element := new Element_Type'(Item); Free_Element (X); @@ -807,7 +812,14 @@ package body Ada.Containers.Indefinite_Hashed_Sets is X := Position.Node.Element; - Position.Node.Element := new Element_Type'(New_Item); + declare + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + begin + Position.Node.Element := new Element_Type'(New_Item); + end; Free_Element (X); end if; @@ -863,6 +875,11 @@ package body Ada.Containers.Indefinite_Hashed_Sets is -------------- function New_Node (Next : Node_Access) return Node_Access is + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + Element : Element_Access := new Element_Type'(New_Item); begin return new Node_Type'(Element, Next); @@ -1317,7 +1334,14 @@ package body Ada.Containers.Indefinite_Hashed_Sets is X := Node.Element; - Node.Element := new Element_Type'(New_Item); + declare + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + begin + Node.Element := new Element_Type'(New_Item); + end; Free_Element (X); end Replace; diff --git a/gcc/ada/a-cimutr.adb b/gcc/ada/a-cimutr.adb index 050c0395dee..4ca89ca11ab 100644 --- a/gcc/ada/a-cimutr.adb +++ b/gcc/ada/a-cimutr.adb @@ -291,7 +291,17 @@ package body Ada.Containers.Indefinite_Multiway_Trees is with "attempt to tamper with cursors (tree is busy)"; end if; - Element := new Element_Type'(New_Item); + declare + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the + -- allocator in the loop below, because the one in this block would + -- have failed already. + begin + Element := new Element_Type'(New_Item); + end; + First := new Tree_Node_Type'(Parent => Parent.Node, Element => Element, others => <>); @@ -1240,7 +1250,17 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Position.Container := Parent.Container; - Element := new Element_Type'(New_Item); + declare + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the + -- allocator in the loop below, because the one in this block would + -- have failed already. + begin + Element := new Element_Type'(New_Item); + end; + Position.Node := new Tree_Node_Type'(Parent => Parent.Node, Element => Element, others => <>); @@ -1805,7 +1825,17 @@ package body Ada.Containers.Indefinite_Multiway_Trees is with "attempt to tamper with cursors (tree is busy)"; end if; - Element := new Element_Type'(New_Item); + declare + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the + -- allocator in the loop below, because the one in this block would + -- have failed already. + begin + Element := new Element_Type'(New_Item); + end; + First := new Tree_Node_Type'(Parent => Parent.Node, Element => Element, others => <>); @@ -2163,7 +2193,14 @@ package body Ada.Containers.Indefinite_Multiway_Trees is with "attempt to tamper with elements (tree is locked)"; end if; - E := new Element_Type'(New_Item); + declare + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + begin + E := new Element_Type'(New_Item); + end; X := Position.Node.Element; Position.Node.Element := E; diff --git a/gcc/ada/a-ciorma.adb b/gcc/ada/a-ciorma.adb index e955dec8915..15e0835db44 100644 --- a/gcc/ada/a-ciorma.adb +++ b/gcc/ada/a-ciorma.adb @@ -812,6 +812,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Position.Node.Key := new Key_Type'(Key); + declare + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). begin Position.Node.Element := new Element_Type'(New_Item); exception @@ -852,6 +857,10 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function New_Node return Node_Access is Node : Node_Access := new Node_Type; + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). begin Node.Key := new Key_Type'(Key); Node.Element := new Element_Type'(New_Item); @@ -1492,6 +1501,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Node.Key := new Key_Type'(Key); + declare + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). begin Node.Element := new Element_Type'(New_Item); exception @@ -1542,6 +1556,10 @@ package body Ada.Containers.Indefinite_Ordered_Maps is declare X : Element_Access := Position.Node.Element; + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). begin Position.Node.Element := new Element_Type'(New_Item); Free_Element (X); diff --git a/gcc/ada/a-ciormu.adb b/gcc/ada/a-ciormu.adb index 928ba9924c4..b7dd81a752a 100644 --- a/gcc/ada/a-ciormu.adb +++ b/gcc/ada/a-ciormu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2012, 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- -- @@ -1167,6 +1167,11 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is -------------- function New_Node return Node_Access is + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + Element : Element_Access := new Element_Type'(New_Item); begin @@ -1768,6 +1773,11 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is declare X : Element_Access := Node.Element; + + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). begin Node.Element := new Element_Type'(Item); Free_Element (X); @@ -1793,6 +1803,10 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is -------------- function New_Node return Node_Access is + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). begin Node.Element := new Element_Type'(Item); -- OK if fails Node.Color := Red_Black_Trees.Red; diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb index 7b919494a17..3eca4c79842 100644 --- a/gcc/ada/a-ciorse.adb +++ b/gcc/ada/a-ciorse.adb @@ -1173,9 +1173,16 @@ package body Ada.Containers.Indefinite_Ordered_Sets is "attempt to tamper with elements (set is locked)"; end if; - X := Position.Node.Element; - Position.Node.Element := new Element_Type'(New_Item); - Free_Element (X); + declare + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + begin + X := Position.Node.Element; + Position.Node.Element := new Element_Type'(New_Item); + Free_Element (X); + end; end if; end Include; @@ -1238,6 +1245,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is -------------- function New_Node return Node_Access is + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + Element : Element_Access := new Element_Type'(New_Item); begin @@ -1818,9 +1830,16 @@ package body Ada.Containers.Indefinite_Ordered_Sets is "attempt to tamper with elements (set is locked)"; end if; - X := Node.Element; - Node.Element := new Element_Type'(New_Item); - Free_Element (X); + declare + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + begin + X := Node.Element; + Node.Element := new Element_Type'(New_Item); + Free_Element (X); + end; end Replace; --------------------- @@ -1854,6 +1873,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is -------------- function New_Node return Node_Access is + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). begin Node.Element := new Element_Type'(Item); -- OK if fails Node.Color := Red; @@ -1883,8 +1906,15 @@ package body Ada.Containers.Indefinite_Ordered_Sets is "attempt to tamper with elements (set is locked)"; end if; - Node.Element := new Element_Type'(Item); - Free_Element (X); + declare + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + begin + Node.Element := new Element_Type'(Item); + Free_Element (X); + end; return; end if; @@ -1901,8 +1931,15 @@ package body Ada.Containers.Indefinite_Ordered_Sets is "attempt to tamper with elements (set is locked)"; end if; - Node.Element := new Element_Type'(Item); - Free_Element (X); + declare + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the + -- case actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + begin + Node.Element := new Element_Type'(Item); + Free_Element (X); + end; return; end if; diff --git a/gcc/ada/a-coinho.adb b/gcc/ada/a-coinho.adb index b6c38b098b6..16334e28d17 100644 --- a/gcc/ada/a-coinho.adb +++ b/gcc/ada/a-coinho.adb @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- A D A . C O N T A I N E R S . B O U N D E D _ V E C T O R S -- +-- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2012, 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- -- @@ -220,8 +220,17 @@ package body Ada.Containers.Indefinite_Holders is raise Program_Error with "attempt to tamper with elements"; end if; - Free (Container.Element); - Container.Element := new Element_Type'(New_Item); + declare + X : Element_Access := Container.Element; + + pragma Unsuppress (Accessibility_Check); + -- Element allocator may need an accessibility check in case actual + -- type is class-wide or has access discriminants (RM 4.8(10.1) and + -- AI12-0035). + begin + Container.Element := new Element_Type'(New_Item); + Free (X); + end; end Replace_Element; --------------- @@ -229,6 +238,10 @@ package body Ada.Containers.Indefinite_Holders is --------------- function To_Holder (New_Item : Element_Type) return Holder is + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the case the + -- actual type is class-wide or has access discriminants (RM 4.8(10.1) + -- and AI12-0035). begin return (AF.Controlled with new Element_Type'(New_Item), 0); end To_Holder; diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index 0627af1b94e..750b5b0540e 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -1698,7 +1698,14 @@ package body Ada.Containers.Indefinite_Vectors is -- value, in case the allocation fails (either because there is no -- storage available, or because element initialization fails). - Container.Elements.EA (Idx) := new Element_Type'(New_Item); + declare + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the + -- case actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + begin + Container.Elements.EA (Idx) := new Element_Type'(New_Item); + end; -- The allocation of the element succeeded, so it is now safe to -- update the Last index, restoring container invariants. @@ -1744,7 +1751,14 @@ package body Ada.Containers.Indefinite_Vectors is -- because there is no storage available, or because element -- initialization fails). - E (Idx) := new Element_Type'(New_Item); + declare + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check + -- in case the actual type is class-wide or has access + -- discriminants (see RM 4.8(10.1) and AI12-0035). + begin + E (Idx) := new Element_Type'(New_Item); + end; -- The allocation of the element succeeded, so it is now -- safe to update the Last index, restoring container @@ -1780,6 +1794,11 @@ package body Ada.Containers.Indefinite_Vectors is -- K always has a value if the exception handler triggers. K := Before; + declare + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in + -- the case the actual type is class-wide or has access + -- discriminants (see RM 4.8(10.1) and AI12-0035). begin while K < Index loop E (K) := new Element_Type'(New_Item); @@ -1885,7 +1904,14 @@ package body Ada.Containers.Indefinite_Vectors is -- because there is no storage available, or because element -- initialization fails). - Dst.EA (Idx) := new Element_Type'(New_Item); + declare + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in + -- the case the actual type is class-wide or has access + -- discriminants (see RM 4.8(10.1) and AI12-0035). + begin + Dst.EA (Idx) := new Element_Type'(New_Item); + end; -- The allocation of the element succeeded, so it is now safe -- to update the Last index, restoring container invariants. @@ -1925,7 +1951,14 @@ package body Ada.Containers.Indefinite_Vectors is -- already been updated), so if this allocation fails we simply -- let it propagate. - Dst.EA (Idx) := new Element_Type'(New_Item); + declare + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in + -- the case the actual type is class-wide or has access + -- discriminants (see RM 4.8(10.1) and AI12-0035). + begin + Dst.EA (Idx) := new Element_Type'(New_Item); + end; end loop; end if; end; @@ -3174,6 +3207,11 @@ package body Ada.Containers.Indefinite_Vectors is declare X : Element_Access := Container.Elements.EA (Index); + + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the case + -- where the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). begin Container.Elements.EA (Index) := new Element_Type'(New_Item); Free (X); @@ -3205,6 +3243,11 @@ package body Ada.Containers.Indefinite_Vectors is declare X : Element_Access := Container.Elements.EA (Position.Index); + + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the case + -- where the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). begin Container.Elements.EA (Position.Index) := new Element_Type'(New_Item); Free (X); @@ -3949,6 +3992,11 @@ package body Ada.Containers.Indefinite_Vectors is Last := Index_Type'First; + declare + pragma Unsuppress (Accessibility_Check); + -- The element allocator may need an accessibility check in the case + -- where the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). begin loop Elements.EA (Last) := new Element_Type'(New_Item); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 76f5a971340..e0b344164bf 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -659,7 +659,7 @@ package body Exp_Ch4 is -- Ada 2005 (AI-344): For an allocator with a class-wide designated -- type, generate an accessibility check to verify that the level of the -- type of the created object is not deeper than the level of the access - -- type. If the type of the qualified expression is class- wide, then + -- type. If the type of the qualified expression is class-wide, then -- always generate the check (except in the case where it is known to be -- unnecessary, see comment below). Otherwise, only generate the check -- if the level of the qualified expression type is statically deeper @@ -690,7 +690,11 @@ package body Exp_Ch4 is (Ref : Node_Id; Built_In_Place : Boolean := False) is - New_Node : Node_Id; + Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT); + Cond : Node_Id; + Free_Stmt : Node_Id; + Obj_Ref : Node_Id; + Stmts : List_Id; begin if Ada_Version >= Ada_2005 @@ -701,6 +705,8 @@ package body Exp_Ch4 is or else (Is_Class_Wide_Type (Etype (Exp)) and then Scope (PtrT) /= Current_Scope)) + and then + (Tagged_Type_Expansion or else VM_Target /= No_VM) then -- If the allocator was built in place, Ref is already a reference -- to the access object initialized to the result of the allocator @@ -712,39 +718,109 @@ package body Exp_Ch4 is if Built_In_Place then Remove_Side_Effects (Ref); - New_Node := New_Copy (Ref); + Obj_Ref := New_Copy (Ref); else - New_Node := New_Reference_To (Ref, Loc); + Obj_Ref := New_Reference_To (Ref, Loc); + end if; + + -- Step 1: Create the object clean up code + + Stmts := New_List; + + -- Create an explicit free statement to clean up the allocated + -- object in case the accessibility check fails. Generate: + + -- Free (Obj_Ref); + + Free_Stmt := Make_Free_Statement (Loc, New_Copy (Obj_Ref)); + Set_Storage_Pool (Free_Stmt, Pool_Id); + + Append_To (Stmts, Free_Stmt); + + -- Finalize the object (if applicable), but wrap the call inside + -- a block to ensure that the object would still be deallocated in + -- case the finalization fails. Generate: + + -- begin + -- [Deep_]Finalize (Obj_Ref.all); + -- exception + -- when others => + -- Free (Obj_Ref); + -- raise; + -- end; + + if Needs_Finalization (DesigT) then + Prepend_To (Stmts, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Final_Call ( + Obj_Ref => + Make_Explicit_Dereference (Loc, + Prefix => New_Copy (Obj_Ref)), + Typ => DesigT)), + + Exception_Handlers => New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => New_List ( + Make_Others_Choice (Loc)), + Statements => New_List ( + New_Copy_Tree (Free_Stmt), + Make_Raise_Statement (Loc))))))); end if; - New_Node := + -- Signal the accessibility failure through a Program_Error + + Append_To (Stmts, + Make_Raise_Program_Error (Loc, + Condition => New_Reference_To (Standard_True, Loc), + Reason => PE_Accessibility_Check_Failed)); + + -- Step 2: Create the accessibility comparison + + -- Generate: + -- Ref'Tag + + Obj_Ref := Make_Attribute_Reference (Loc, - Prefix => New_Node, + Prefix => Obj_Ref, Attribute_Name => Name_Tag); + -- For tagged types, determine the accessibility level by looking + -- at the type specific data of the dispatch table. Generate: + + -- Type_Specific_Data (Address (Ref'Tag)).Access_Level + if Tagged_Type_Expansion then - New_Node := Build_Get_Access_Level (Loc, New_Node); + Cond := Build_Get_Access_Level (Loc, Obj_Ref); - elsif VM_Target /= No_VM then - New_Node := - Make_Function_Call (Loc, - Name => New_Reference_To (RTE (RE_Get_Access_Level), Loc), - Parameter_Associations => New_List (New_Node)); + -- Use a runtime call to determine the accessibility level when + -- compiling on virtual machine targets. Generate: - -- Cannot generate the runtime check + -- Get_Access_Level (Ref'Tag) else - return; + Cond := + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Get_Access_Level), Loc), + Parameter_Associations => New_List (Obj_Ref)); end if; + Cond := + Make_Op_Gt (Loc, + Left_Opnd => Cond, + Right_Opnd => + Make_Integer_Literal (Loc, Type_Access_Level (PtrT))); + + -- Due to the complexity and side effects of the check, utilize an + -- if statement instead of the regular Program_Error circuitry. + Insert_Action (N, - Make_Raise_Program_Error (Loc, - Condition => - Make_Op_Gt (Loc, - Left_Opnd => New_Node, - Right_Opnd => - Make_Integer_Literal (Loc, Type_Access_Level (PtrT))), - Reason => PE_Accessibility_Check_Failed)); + Make_If_Statement (Loc, + Condition => Cond, + Then_Statements => Stmts)); end if; end Apply_Accessibility_Check; diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index a05e79b51d6..4f6ccb52339 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -1562,7 +1562,12 @@ package body Ch6 is ("(style) IN should be omitted"); end if; - if Token = Tok_Access then + -- Since Ada 2005, formal objects can have an anonymous access type, + -- and of course carry a mode indicator. + + if Token = Tok_Access + and then Nkind (Node) /= N_Formal_Object_Declaration + then Error_Msg_SP ("IN not allowed together with ACCESS"); Scan; -- past ACCESS end if; diff --git a/gcc/ada/projects.texi b/gcc/ada/projects.texi index 1c0c593ac15..2fff4eb1fab 100644 --- a/gcc/ada/projects.texi +++ b/gcc/ada/projects.texi @@ -342,8 +342,8 @@ locating the specified source files in the specified source directories. is explicitly specified. @xref{Naming Schemes}. -@item @code{Source Files} - @cindex @code{Source_Files} +@item @code{Source_Files} +@cindex @code{Source_Files} In some cases, source directories might contain files that should not be included in a project. One can specify the explicit list of file names to be considered through the @b{Source_Files} attribute. diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 563d5b80c21..843f67bc0d1 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -253,7 +253,7 @@ package body Sem_Ch4 is function Try_Container_Indexing (N : Node_Id; Prefix : Node_Id; - Expr : Node_Id) return Boolean; + Exprs : List_Id) return Boolean; -- AI05-0139: Generalized indexing to support iterators over containers function Try_Indexed_Call @@ -2114,7 +2114,7 @@ package body Sem_Ch4 is then return; - elsif Try_Container_Indexing (N, P, Exp) then + elsif Try_Container_Indexing (N, P, Exprs) then return; elsif Array_Type = Any_Type then @@ -2276,7 +2276,7 @@ package body Sem_Ch4 is end; end if; - elsif Try_Container_Indexing (N, P, First (Exprs)) then + elsif Try_Container_Indexing (N, P, Exprs) then return; end if; @@ -6475,9 +6475,10 @@ package body Sem_Ch4 is function Try_Container_Indexing (N : Node_Id; Prefix : Node_Id; - Expr : Node_Id) return Boolean + Exprs : List_Id) return Boolean is Loc : constant Source_Ptr := Sloc (N); + Assoc : List_Id; Disc : Entity_Id; Func : Entity_Id; Func_Name : Node_Id; @@ -6508,19 +6509,34 @@ package body Sem_Ch4 is if Has_Implicit_Dereference (Etype (Prefix)) then Build_Explicit_Dereference (Prefix, First_Discriminant (Etype (Prefix))); - return Try_Container_Indexing (N, Prefix, Expr); + return Try_Container_Indexing (N, Prefix, Exprs); else return False; end if; end if; + Assoc := New_List (Relocate_Node (Prefix)); + + -- A generalized iterator may have nore than one index expression, so + -- transfer all of them to the argument list to be used in the call. + + declare + Arg : Node_Id; + + begin + Arg := First (Exprs); + while Present (Arg) loop + Append (Relocate_Node (Arg), Assoc); + Next (Arg); + end loop; + end; + if not Is_Overloaded (Func_Name) then Func := Entity (Func_Name); Indexing := Make_Function_Call (Loc, Name => New_Occurrence_Of (Func, Loc), - Parameter_Associations => - New_List (Relocate_Node (Prefix), Relocate_Node (Expr))); + Parameter_Associations => Assoc); Rewrite (N, Indexing); Analyze (N); @@ -6544,8 +6560,7 @@ package body Sem_Ch4 is else Indexing := Make_Function_Call (Loc, Name => Make_Identifier (Loc, Chars (Func_Name)), - Parameter_Associations => - New_List (Relocate_Node (Prefix), Relocate_Node (Expr))); + Parameter_Associations => Assoc); Rewrite (N, Indexing); @@ -6586,7 +6601,8 @@ package body Sem_Ch4 is end if; if Etype (N) = Any_Type then - Error_Msg_NE ("container cannot be indexed with&", N, Etype (Expr)); + Error_Msg_NE ("container cannot be indexed with&", + N, Etype (First (Exprs))); Rewrite (N, New_Occurrence_Of (Any_Id, Loc)); else Analyze (N); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index eb2b509e1ab..5f25a862c16 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -7057,11 +7057,16 @@ package body Sem_Res is Loc : constant Source_Ptr := Sloc (N); New_N : Node_Id; P : constant Node_Id := Prefix (N); + + P_Typ : Entity_Id; + -- The candidate prefix type, if overloaded + I : Interp_Index; It : Interp; begin Check_Fully_Declared_Prefix (Typ, P); + P_Typ := Empty; if Is_Overloaded (P) then @@ -7069,14 +7074,28 @@ package body Sem_Res is -- designated type. Get_First_Interp (P, I, It); + while Present (It.Typ) loop - exit when Is_Access_Type (It.Typ) - and then Covers (Typ, Designated_Type (It.Typ)); + if Is_Access_Type (It.Typ) + and then Covers (Typ, Designated_Type (It.Typ)) + then + P_Typ := It.Typ; + + -- Remove access types that do not match, but preserve access + -- to subprogram interpretations, in case a further dereference + -- is needed (see below). + + elsif Ekind (It.Typ) /= E_Access_Subprogram_Type then + Remove_Interp (I); + end if; + Get_Next_Interp (I, It); end loop; - if Present (It.Typ) then - Resolve (P, It.Typ); + if Present (P_Typ) then + Resolve (P, P_Typ); + Set_Etype (N, Designated_Type (P_Typ)); + else -- If no interpretation covers the designated type of the prefix, -- this is the pathological case where not all implementations of @@ -7107,9 +7126,9 @@ package body Sem_Res is return; end if; - Set_Etype (N, Designated_Type (It.Typ)); - else + -- If not overloaded, resolve P with its own type + Resolve (P); end if; |