diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 22 | ||||
| -rw-r--r-- | gcc/ada/par-ch4.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 160 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 134 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/sinfo.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 18 |
8 files changed, 371 insertions, 24 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7b8561bff94..ce02f4f2889 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,25 @@ +2011-08-05 Bob Duff <duff@adacore.com> + + * sinfo.ads, sinfo.adb (Subpool_Handle_Name): New attribute for + subpools. + * par-ch4.adb (P_Allocator): Parse new subpool specification syntax. + +2011-08-05 Ed Schonberg <schonberg@adacore.com> + + * sem_ch4.adb (Try_Container_Indexing): New procedure to implement the + general indexing aspects of Ada2012. Called when analyzing indexed + components when other interpretations fail. + * sem_ch8.adb (Find_Direct_Name): check for implicit dereference only + in an expression context where overloading is meaningful. This excludes + the occurrence in an aspect specification (efficiency only). + * sem_attr.adb (Analyze_Attribute): indicate that the attributes + related to iterators can be set by an attribute specification, but + cannot be queried. + * sem_ch13.adb (Analyze_Aspect_Specifications): handle + Constant_Indexing and Variable_Indexing. + (Check_Indexing_Functions): New procedure to perform legality checks. + Additional semantic checks at end of declarations. + 2011-08-05 Sergey Rybin <rybin@adacore.com> * tree_io.ads: Update ASIS_Version_Number because of the change of the diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 125a9c4a1e0..cbe68cfddaa 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -2810,7 +2810,10 @@ package body Ch4 is -------------------- -- ALLOCATOR ::= - -- new [NULL_EXCLUSION] SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION + -- new [SUBPOOL_SPECIFICATION] SUBTYPE_INDICATION + -- | new [SUBPOOL_SPECIFICATION] QUALIFIED_EXPRESSION + -- + -- SUBPOOL_SPECIFICATION ::= (subpool_handle_NAME) -- The caller has checked that the initial token is NEW @@ -2825,8 +2828,25 @@ package body Ch4 is Alloc_Node := New_Node (N_Allocator, Token_Ptr); T_New; + -- Scan subpool_specification if present (Ada 2012 (AI05-0111-3)) + -- Scan Null_Exclusion if present (Ada 2005 (AI-231)) + if Token = Tok_Left_Paren then + Scan; -- past ( + Set_Subpool_Handle_Name (Alloc_Node, P_Name); + T_Right_Paren; + + if Ada_Version < Ada_2012 then + Error_Msg_N + ("|subpool specification is an Ada 2012 feature", + Subpool_Handle_Name (Alloc_Node)); + Error_Msg_N + ("\|unit must be compiled with -gnat2012 switch", + Subpool_Handle_Name (Alloc_Node)); + end if; + end if; + Null_Exclusion_Present := P_Null_Exclusion; Set_Null_Exclusion_Present (Alloc_Node, Null_Exclusion_Present); Type_Node := P_Subtype_Mark_Resync; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index de7fd3ef9b2..5195e4f3a88 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -2110,13 +2110,15 @@ package body Sem_Attr is case Attr_Id is - -- Attributes related to Ada2012 iterators (placeholder ???) - - when Attribute_Constant_Indexing => null; - when Attribute_Default_Iterator => null; - when Attribute_Implicit_Dereference => null; - when Attribute_Iterator_Element => null; - when Attribute_Variable_Indexing => null; + -- Attributes related to Ada2012 iterators. Attribute specifications + -- exist for these, but they cannot be queried. + + when Attribute_Constant_Indexing | + Attribute_Default_Iterator | + Attribute_Implicit_Dereference | + Attribute_Iterator_Element | + Attribute_Variable_Indexing => + Error_Msg_N ("illegal attribute", N); ------------------ -- Abort_Signal -- diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 4a9e9a94cf1..f2075d0cae9 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -946,13 +946,36 @@ package body Sem_Ch13 is Delay_Required := False; - -- Aspects related to container iterators (fill in later???) + -- Aspects related to container iterators. These aspects denote + -- subprograms, and thus must be delayed. when Aspect_Constant_Indexing | - Aspect_Default_Iterator | - Aspect_Iterator_Element | Aspect_Variable_Indexing => - null; + + if not Is_Type (E) or else not Is_Tagged_Type (E) then + Error_Msg_N ("indexing applies to a tagged type", N); + end if; + + Aitem := + Make_Attribute_Definition_Clause (Loc, + Name => Ent, + Chars => Chars (Id), + Expression => Relocate_Node (Expr)); + + Delay_Required := True; + Set_Is_Delayed_Aspect (Aspect); + + when Aspect_Default_Iterator | + Aspect_Iterator_Element => + + Aitem := + Make_Attribute_Definition_Clause (Loc, + Name => Ent, + Chars => Chars (Id), + Expression => Relocate_Node (Expr)); + + Delay_Required := True; + Set_Is_Delayed_Aspect (Aspect); when Aspect_Implicit_Dereference => if not Is_Type (E) @@ -1511,6 +1534,11 @@ package body Sem_Ch13 is -- and if so gives an error message. If there is a duplicate, True is -- returned, otherwise if there is no error, False is returned. + procedure Check_Indexing_Functions; + -- Check that the function in Constant_Indexing or Variable_Indexing + -- attribute has the proper type structure. If the name is overloaded, + -- check that all interpretations are legal. + ----------------------------------- -- Analyze_Stream_TSS_Definition -- ----------------------------------- @@ -1648,6 +1676,89 @@ package body Sem_Ch13 is end if; end Analyze_Stream_TSS_Definition; + ------------------------------ + -- Check_Indexing_Functions -- + ------------------------------ + + procedure Check_Indexing_Functions is + Ctrl : Entity_Id; + + procedure Check_One_Function (Subp : Entity_Id); + -- Check one possible interpretation + + ------------------------ + -- Check_One_Function -- + ------------------------ + + procedure Check_One_Function (Subp : Entity_Id) is + begin + if Ekind (Subp) /= E_Function then + Error_Msg_N ("indexing requires a function", Subp); + end if; + + if No (First_Formal (Subp)) then + Error_Msg_N + ("function for indexing must have parameters", Subp); + else + Ctrl := Etype (First_Formal (Subp)); + end if; + + if Ctrl = Ent + or else Ctrl = Class_Wide_Type (Ent) + or else + (Ekind (Ctrl) = E_Anonymous_Access_Type + and then + (Designated_Type (Ctrl) = Ent + or else Designated_Type (Ctrl) = Class_Wide_Type (Ent))) + then + null; + + else + Error_Msg_N ("indexing function must apply to type&", Subp); + end if; + + if No (Next_Formal (First_Formal (Subp))) then + Error_Msg_N + ("function for indexing must have two parameters", Subp); + end if; + + if not Has_Implicit_Dereference (Etype (Subp)) then + Error_Msg_N + ("function for indexing must return a reference type", Subp); + end if; + end Check_One_Function; + + -- Start of processing for Check_Indexing_Functions + + begin + Analyze (Expr); + + if not Is_Overloaded (Expr) then + Check_One_Function (Entity (Expr)); + + else + declare + I : Interp_Index; + It : Interp; + + begin + Get_First_Interp (Expr, I, It); + while Present (It.Nam) loop + + -- Note that analysis will have added the interpretation + -- that corresponds to the dereference. We only check the + -- subprogram itself. + + if Is_Overloadable (It.Nam) then + Check_One_Function (It.Nam); + end if; + + Get_Next_Interp (I, It); + end loop; + end; + end if; + end Check_Indexing_Functions; + ---------------------- -- Duplicate_Clause -- ---------------------- @@ -2267,6 +2378,13 @@ package body Sem_Ch13 is end if; end Component_Size_Case; + ----------------------- + -- Constant_Indexing -- + ----------------------- + + when Attribute_Constant_Indexing => + Check_Indexing_Functions; + ------------------ -- External_Tag -- ------------------ @@ -2845,6 +2963,13 @@ package body Sem_Ch13 is end if; end Value_Size; + ----------------------- + -- Variable_Indexing -- + ----------------------- + + when Attribute_Variable_Indexing => + Check_Indexing_Functions; + ----------- -- Write -- ----------- @@ -5381,6 +5506,13 @@ package body Sem_Ch13 is Analyze (End_Decl_Expr); Err := Entity (End_Decl_Expr) /= Entity (Freeze_Expr); + elsif A_Id = Aspect_Variable_Indexing or else + A_Id = Aspect_Constant_Indexing + then + Analyze (End_Decl_Expr); + Analyze (Aspect_Rep_Item (ASN)); + Err := Entity (End_Decl_Expr) /= Entity (Freeze_Expr); + -- All other cases else @@ -5485,15 +5617,6 @@ package body Sem_Ch13 is Aspect_Value_Size => T := Any_Integer; - -- Following to be done later ??? - - when Aspect_Constant_Indexing | - Aspect_Default_Iterator | - Aspect_Iterator_Element | - Aspect_Implicit_Dereference | - Aspect_Variable_Indexing => - null; - -- Stream attribute. Special case, the expression is just an entity -- that does not need any resolution, so just analyze. @@ -5504,6 +5627,17 @@ package body Sem_Ch13 is Analyze (Expression (ASN)); return; + -- Same for Iterator aspects, where the expression is a function + -- name. Legality rules are checked separately. + + when Aspect_Constant_Indexing | + Aspect_Default_Iterator | + Aspect_Iterator_Element | + Aspect_Implicit_Dereference | + Aspect_Variable_Indexing => + Analyze (Expression (ASN)); + return; + -- Suppress/Unsuppress/Warnings should never be delayed when Aspect_Suppress | diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index e2521687627..3d7b48ff075 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; use Aspects; with Atree; use Atree; with Debug; use Debug; with Einfo; use Einfo; @@ -248,6 +249,12 @@ package body Sem_Ch4 is -- Ada 2005: implementation of AI-310. An abstract non-dispatching -- operation is not a candidate interpretation. + function Try_Container_Indexing + (N : Node_Id; + Prefix : Node_Id; + Expr : Node_Id) return Boolean; + -- AI05-0139: Generalized indexing to support iterators over containers + function Try_Indexed_Call (N : Node_Id; Nam : Entity_Id; @@ -2032,6 +2039,9 @@ package body Sem_Ch4 is then return; + elsif Try_Container_Indexing (N, P, Exp) then + return; + elsif Array_Type = Any_Type then Set_Etype (N, Any_Type); @@ -6270,6 +6280,130 @@ package body Sem_Ch4 is end if; end Remove_Abstract_Operations; + ---------------------------- + -- Try_Container_Indexing -- + ---------------------------- + + function Try_Container_Indexing + (N : Node_Id; + Prefix : Node_Id; + Expr : Node_Id) return Boolean + is + Loc : constant Source_Ptr := Sloc (N); + Disc : Entity_Id; + Func : Entity_Id; + Func_Name : Node_Id; + Indexing : Node_Id; + Is_Var : Boolean; + Ritem : Node_Id; + + begin + + -- Check whether type has a specified indexing aspect. + + Func_Name := Empty; + Is_Var := False; + Ritem := First_Rep_Item (Etype (Prefix)); + + while Present (Ritem) loop + if Nkind (Ritem) = N_Aspect_Specification then + + -- Prefer Variable_Indexing, but will settle for Constant. + + if Get_Aspect_Id (Chars (Identifier (Ritem))) = + Aspect_Constant_Indexing + then + Func_Name := Expression (Ritem); + + elsif Get_Aspect_Id (Chars (Identifier (Ritem))) = + Aspect_Variable_Indexing + then + Func_Name := Expression (Ritem); + Is_Var := True; + exit; + end if; + end if; + Next_Rep_Item (Ritem); + end loop; + + -- If aspect does not exist the expression is illegal. Error is + -- diagnosed in caller. + + if No (Func_Name) then + return False; + end if; + + if Is_Var + and then not Is_Variable (Prefix) + then + Error_Msg_N ("Variable indexing cannot be applied to a constant", N); + end if; + + 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))); + Rewrite (N, Indexing); + Analyze (N); + + -- The return type of the indexing function is a reference type, so + -- add the dereference as a possible interpretation. + + Disc := First_Discriminant (Etype (Func)); + while Present (Disc) loop + if Has_Implicit_Dereference (Disc) then + Add_One_Interp (N, Disc, Designated_Type (Etype (Disc))); + exit; + end if; + + Next_Discriminant (Disc); + end loop; + + else + Indexing := Make_Function_Call (Loc, + Name => Make_Identifier (Loc, Chars (Func_Name)), + Parameter_Associations => + New_List (Relocate_Node (Prefix), Relocate_Node (Expr))); + + Rewrite (N, Indexing); + + declare + I : Interp_Index; + It : Interp; + Success : Boolean; + + begin + Get_First_Interp (Func_Name, I, It); + Set_Etype (N, Any_Type); + while Present (It.Nam) loop + Analyze_One_Call (N, It.Nam, False, Success); + if Success then + Set_Etype (Name (N), It.Typ); + + -- Add implicit dereference interpretation. + + Disc := First_Discriminant (Etype (It.Nam)); + + while Present (Disc) loop + if Has_Implicit_Dereference (Disc) then + Add_One_Interp + (N, Disc, Designated_Type (Etype (Disc))); + exit; + end if; + + Next_Discriminant (Disc); + end loop; + end if; + Get_Next_Interp (I, It); + end loop; + end; + end if; + + return True; + end Try_Container_Indexing; + ----------------------- -- Try_Indirect_Call -- ----------------------- diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 75813a4d729..cf623bef718 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -4818,7 +4818,12 @@ package body Sem_Ch8 is end if; Set_Entity_Or_Discriminal (N, E); - Check_Implicit_Dereference (N, Etype (E)); + + if Ada_Version >= Ada_2012 + and then Nkind (Parent (N)) in N_Subexpr + then + Check_Implicit_Dereference (N, Etype (E)); + end if; end if; end; end Find_Direct_Name; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 5ff5c474c6e..73b848946f2 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -2844,6 +2844,14 @@ package body Sinfo is return Node1 (N); end Storage_Pool; + function Subpool_Handle_Name + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Allocator); + return Node4 (N); + end Subpool_Handle_Name; + function Strval (N : Node_Id) return String_Id is begin @@ -5886,6 +5894,14 @@ package body Sinfo is Set_Node1 (N, Val); -- semantic field, no parent set end Set_Storage_Pool; + procedure Set_Subpool_Handle_Name + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Allocator); + Set_Node4_With_Parent (N, Val); + end Set_Subpool_Handle_Name; + procedure Set_Strval (N : Node_Id; Val : String_Id) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index c9e051283e2..eca688af230 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -3933,14 +3933,20 @@ package Sinfo is -------------------- -- ALLOCATOR ::= - -- new [NULL_EXCLUSION] SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION + -- new [SUBPOOL_SPECIFICATION] SUBTYPE_INDICATION + -- | new [SUBPOOL_SPECIFICATION] QUALIFIED_EXPRESSION + -- + -- SUBPOOL_SPECIFICATION ::= (subpool_handle_NAME) -- Sprint syntax (when storage pool present) -- new xxx (storage_pool = pool) + -- or + -- new (subpool) xxx (storage_pool = pool) -- N_Allocator -- Sloc points to NEW -- Expression (Node3) subtype indication or qualified expression + -- Subpool_Handle_Name (Node4) (set to Empty if not present) -- Storage_Pool (Node1-Sem) -- Procedure_To_Call (Node2-Sem) -- Null_Exclusion_Present (Flag11) @@ -8911,6 +8917,9 @@ package Sinfo is function Storage_Pool (N : Node_Id) return Node_Id; -- Node1 + function Subpool_Handle_Name + (N : Node_Id) return Node_Id; -- Node4 + function Strval (N : Node_Id) return String_Id; -- Str3 @@ -9880,6 +9889,9 @@ package Sinfo is procedure Set_Storage_Pool (N : Node_Id; Val : Node_Id); -- Node1 + procedure Set_Subpool_Handle_Name + (N : Node_Id; Val : Node_Id); -- Node4 + procedure Set_Strval (N : Node_Id; Val : String_Id); -- Str3 @@ -10656,7 +10668,7 @@ package Sinfo is (1 => False, -- Storage_Pool (Node1-Sem) 2 => False, -- Procedure_To_Call (Node2-Sem) 3 => True, -- Expression (Node3) - 4 => False, -- unused + 4 => True, -- Subpool_Handle_Name (Node4) 5 => False), -- Etype (Node5-Sem) N_Null_Statement => @@ -11997,6 +12009,7 @@ package Sinfo is pragma Inline (Statements); pragma Inline (Static_Processing_OK); pragma Inline (Storage_Pool); + pragma Inline (Subpool_Handle_Name); pragma Inline (Strval); pragma Inline (Subtype_Indication); pragma Inline (Subtype_Mark); @@ -12316,6 +12329,7 @@ package Sinfo is pragma Inline (Set_Statements); pragma Inline (Set_Static_Processing_OK); pragma Inline (Set_Storage_Pool); + pragma Inline (Set_Subpool_Handle_Name); pragma Inline (Set_Strval); pragma Inline (Set_Subtype_Indication); pragma Inline (Set_Subtype_Mark); |