diff options
Diffstat (limited to 'gcc/ada')
-rw-r--r-- | gcc/ada/ChangeLog | 24 | ||||
-rw-r--r-- | gcc/ada/par-ch4.adb | 13 | ||||
-rw-r--r-- | gcc/ada/sem_aggr.adb | 116 | ||||
-rw-r--r-- | gcc/ada/sem_ch13.adb | 8 | ||||
-rw-r--r-- | gcc/ada/sinfo.adb | 12 | ||||
-rw-r--r-- | gcc/ada/sinfo.ads | 5 | ||||
-rw-r--r-- | gcc/ada/sprint.adb | 2 |
7 files changed, 150 insertions, 30 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a0f6f81..1ec581c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,27 @@ +2017-01-13 Gary Dismukes <dismukes@adacore.com> + + * sem_ch13.adb: Minor reformatting and typo fix. + +2017-01-13 Ed Schonberg <schonberg@adacore.com> + + * par-ch4.adb (P_Aggregate_Or_Parent_Expr): An + Iterated_Component_Association is a named association in an + array aggregate. + * sem_aggr.adb (Resolve_Iterated_Component_Association): New + procedure, subsidiary of Resolve_Array_Aggregate, to analyze + and resolve the discrete choices and the expression of the + new construct. + * sinfo.adb, sinfo.ads: In analogy with N_Component_Association, + Loop_Actions and Box_Present are attributes of + N_Iterated_Component_Association nodes. Box_Present is always + False in this case. + * sprint.adb (Sprint_Node): An Iterated_Component_Association + has a Discrete_Choices list, as specified in the RM. A + Component_Association for aggregate uses instead a Choices list. + We have to live with this small inconsistency because the new + construct also has a defining identifier, and there is no way + to merge the two node structures. + 2017-01-13 Yannick Moy <moy@adacore.com> * inline.adb (Remove_Aspects_And_Pragmas): Add Unused to the diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 7bbd48b..f52b6ad 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -1490,7 +1490,14 @@ package body Ch4 is -- Assume positional case if comma, right paren, or literal or -- identifier or OTHERS follows (the latter cases are missing -- comma cases). Also assume positional if a semicolon follows, - -- which can happen if there are missing parens + -- which can happen if there are missing parens. + + elsif Nkind (Expr_Node) = N_Iterated_Component_Association then + if No (Assoc_List) then + Assoc_List := New_List (Expr_Node); + else + Append_To (Assoc_List, Expr_Node); + end if; elsif Token = Tok_Comma or else Token = Tok_Right_Paren @@ -1500,8 +1507,8 @@ package body Ch4 is then if Present (Assoc_List) then Error_Msg_BC -- CODEFIX - ("""='>"" expected (positional association cannot follow " & - "named association)"); + ("""='>"" expected (positional association cannot follow " + & "named association)"); end if; if No (Expr_List) then diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 8630554..1b9f0af 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -1180,6 +1180,11 @@ package body Sem_Aggr is Index_Base_High : constant Node_Id := Type_High_Bound (Index_Base); -- Ditto for the base type + Others_Present : Boolean := False; + + Nb_Choices : Nat := 0; + -- Contains the overall number of named choices in this sub-aggregate + function Add (Val : Uint; To : Node_Id) return Node_Id; -- Creates a new expression node where Val is added to expression To. -- Tries to constant fold whenever possible. To must be an already @@ -1202,6 +1207,10 @@ package body Sem_Aggr is function Dynamic_Or_Null_Range (L, H : Node_Id) return Boolean; -- Returns True if range L .. H is dynamic or null + function Choice_List (N : Node_Id) return List_Id; + -- Utility to retrieve the choices of a Component_Association or the + -- Discrete_Choices of an Iterated_Component_Association. + procedure Get (Value : out Uint; From : Node_Id; OK : out Boolean); -- Given expression node From, this routine sets OK to False if it -- cannot statically evaluate From. Otherwise it stores this static @@ -1221,6 +1230,11 @@ package body Sem_Aggr is -- N_Component_Association node as Expr, since there is no Expression in -- that case, and we need a Sloc for the error message. + procedure Resolve_Iterated_Component_Association + (N : Node_Id; + Index_Typ : Entity_Id); + -- For AI12-061 + --------- -- Add -- --------- @@ -1459,6 +1473,19 @@ package body Sem_Aggr is or else Val_L > Val_H; end Dynamic_Or_Null_Range; + ----------------- + -- Choice_List -- + ----------------- + + function Choice_List (N : Node_Id) return List_Id is + begin + if Nkind (N) = N_Iterated_Component_Association then + return Discrete_Choices (N); + else + return Choices (N); + end if; + end Choice_List; + --------- -- Get -- --------- @@ -1626,38 +1653,83 @@ package body Sem_Aggr is return Resolution_OK; end Resolve_Aggr_Expr; - -- Variables local to Resolve_Array_Aggregate + -------------------------------------------- + -- Resolve_Iterated_Component_Association -- + -------------------------------------------- + + procedure Resolve_Iterated_Component_Association + (N : Node_Id; + Index_Typ : Entity_Id) + is + Id : constant Entity_Id := Defining_Identifier (N); + Loc : constant Source_Ptr := Sloc (N); + + Choice : Node_Id; + Dummy : Boolean; + Ent : Entity_Id; + + begin + Choice := First (Discrete_Choices (N)); + + while Present (Choice) loop + if Nkind (Choice) = N_Others_Choice then + Error_Msg_N ("others choice not allowed in this context", N); + Others_Present := True; + + else + Analyze_And_Resolve (Choice, Index_Typ); + end if; + + Nb_Choices := Nb_Choices + 1; + Next (Choice); + end loop; + + -- Create a scope in which to introduce an index, which is usually + -- visible in the expression for the component. + + Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L'); + Set_Etype (Ent, Standard_Void_Type); + Set_Parent (Ent, Parent (N)); + + Enter_Name (Id); + Set_Etype (Id, Index_Typ); + Set_Ekind (Id, E_Variable); + Set_Scope (Id, Ent); + + Push_Scope (Ent); + Dummy := Resolve_Aggr_Expr (Expression (N), False); + End_Scope; + end Resolve_Iterated_Component_Association; + + -- Local variables Assoc : Node_Id; Choice : Node_Id; Expr : Node_Id; Discard : Node_Id; - Delete_Choice : Boolean; - -- Used when replacing a subtype choice with predicate by a list + Iterated_Component_Present : Boolean := False; Aggr_Low : Node_Id := Empty; Aggr_High : Node_Id := Empty; -- The actual low and high bounds of this sub-aggregate + Case_Table_Size : Nat; + -- Contains the size of the case table needed to sort aggregate choices + Choices_Low : Node_Id := Empty; Choices_High : Node_Id := Empty; -- The lowest and highest discrete choices values for a named aggregate + Delete_Choice : Boolean; + -- Used when replacing a subtype choice with predicate by a list + Nb_Elements : Uint := Uint_0; -- The number of elements in a positional aggregate - Others_Present : Boolean := False; - - Nb_Choices : Nat := 0; - -- Contains the overall number of named choices in this sub-aggregate - Nb_Discrete_Choices : Nat := 0; -- The overall number of discrete choices (not counting others choice) - Case_Table_Size : Nat; - -- Contains the size of the case table needed to sort aggregate choices - -- Start of processing for Resolve_Array_Aggregate begin @@ -1675,6 +1747,12 @@ package body Sem_Aggr is if Present (Component_Associations (N)) then Assoc := First (Component_Associations (N)); while Present (Assoc) loop + if Nkind (Assoc) = N_Iterated_Component_Association then + Resolve_Iterated_Component_Association (Assoc, Index_Typ); + Iterated_Component_Present := True; + goto Next_Assoc; + end if; + Choice := First (Choices (Assoc)); Delete_Choice := False; while Present (Choice) loop @@ -1766,6 +1844,7 @@ package body Sem_Aggr is end; end loop; + <<Next_Assoc>> Next (Assoc); end loop; end if; @@ -1780,7 +1859,7 @@ package body Sem_Aggr is then Error_Msg_N ("named association cannot follow positional association", - First (Choices (First (Component_Associations (N))))); + First (Choice_List (First (Component_Associations (N))))); return Failure; end if; @@ -1860,7 +1939,8 @@ package body Sem_Aggr is Assoc := First (Component_Associations (N)); while Present (Assoc) loop Prev_Nb_Discrete_Choices := Nb_Discrete_Choices; - Choice := First (Choices (Assoc)); + Choice := First (Choice_List (Assoc)); + loop Analyze (Choice); @@ -2475,11 +2555,7 @@ package body Sem_Aggr is Check_Can_Never_Be_Null (Etype (N), Expr); end if; - if Nkind (Expr) = N_Iterated_Component_Association then - Error_Msg_N ("iterated association not implemented yet", Expr); - return Failure; - - elsif not Resolve_Aggr_Expr (Expr, Single_Elmt => True) then + if not Resolve_Aggr_Expr (Expr, Single_Elmt => True) then return Failure; end if; @@ -2645,6 +2721,10 @@ package body Sem_Aggr is Analyze_Dimension_Array_Aggregate (N, Component_Typ); + if Iterated_Component_Present then + Error_Msg_N ("iterated association not implemented yet", N); + end if; + return Success; end Resolve_Array_Aggregate; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 142ac8e..ba47f92 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -8963,12 +8963,12 @@ package body Sem_Ch13 is -- Expression to be analyzed at end of declarations Freeze_Expr : constant Node_Id := Expression (ASN); - -- Expression from call to Check_Aspect_At_Freeze_Point. We use + -- Expression from call to Check_Aspect_At_Freeze_Point. T : constant Entity_Id := Etype (Original_Node (Freeze_Expr)); - -- Type required for preanalyze call. We use the originsl - -- expression to get the proper type, to prevent cascaded errors - -- when the expression is constant-folded. + -- Type required for preanalyze call. We use the original expression to + -- get the proper type, to prevent cascaded errors when the expression + -- is constant-folded. Err : Boolean; -- Set False if error diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index dbe51ec..a99790b 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -366,7 +366,8 @@ package body Sinfo is or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration or else NT (N).Nkind = N_Formal_Package_Declaration - or else NT (N).Nkind = N_Generic_Association); + or else NT (N).Nkind = N_Generic_Association + or else NT (N).Nkind = N_Iterated_Component_Association); return Flag15 (N); end Box_Present; @@ -2201,7 +2202,8 @@ package body Sinfo is (N : Node_Id) return List_Id is begin pragma Assert (False - or else NT (N).Nkind = N_Component_Association); + or else NT (N).Nkind = N_Component_Association + or else NT (N).Nkind = N_Iterated_Component_Association); return List2 (N); end Loop_Actions; @@ -3665,7 +3667,8 @@ package body Sinfo is or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration or else NT (N).Nkind = N_Formal_Package_Declaration - or else NT (N).Nkind = N_Generic_Association); + or else NT (N).Nkind = N_Generic_Association + or else NT (N).Nkind = N_Iterated_Component_Association); Set_Flag15 (N, Val); end Set_Box_Present; @@ -5491,7 +5494,8 @@ package body Sinfo is (N : Node_Id; Val : List_Id) is begin pragma Assert (False - or else NT (N).Nkind = N_Component_Association); + or else NT (N).Nkind = N_Component_Association + or else NT (N).Nkind = N_Iterated_Component_Association); Set_List2 (N, Val); -- semantic field, no parent set end Set_Loop_Actions; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 588d02e..5ad8bbc 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -4114,8 +4114,13 @@ package Sinfo is -- N_Iterated_Component_Association -- Sloc points to FOR -- Defining_Identifier (Node1) + -- Loop_Actions (List2-Sem) -- Expression (Node3) -- Discrete_Choices (List4) + -- Box_Present (Flag15) + + -- Note that Box_Present is always False, but it is intentionally added + -- for completeness. -------------------------------------------------- -- 4.4 Expression/Relation/Term/Factor/Primary -- diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 3951b57..a357fb2 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -1333,7 +1333,7 @@ package body Sprint is Write_Str (" for "); Write_Id (Defining_Identifier (Node)); Write_Str (" in "); - Sprint_Bar_List (Choices (Node)); + Sprint_Bar_List (Discrete_Choices (Node)); Write_Str (" => "); Sprint_Node (Expression (Node)); |