diff options
Diffstat (limited to 'gcc/ada/par-ch4.adb')
-rw-r--r-- | gcc/ada/par-ch4.adb | 120 |
1 files changed, 118 insertions, 2 deletions
diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 52f2b02..2ff6e00 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -1393,6 +1393,8 @@ package body Ch4 is Start_Token : constant Token_Type := Token; -- Used to prevent mismatches (...] and [...) + Saved_Delta_Aggregate_Flag : constant Boolean := Inside_Delta_Aggregate; + -- Start of processing for P_Aggregate_Or_Paren_Expr begin @@ -1497,6 +1499,7 @@ package body Ch4 is Scan; -- past WITH if Token = Tok_Delta then Scan; -- past DELTA + Inside_Delta_Aggregate := True; Aggregate_Node := New_Node (N_Delta_Aggregate, Lparen_Sloc); Set_Expression (Aggregate_Node, Expr_Node); Expr_Node := Empty; @@ -1707,6 +1710,16 @@ package body Ch4 is end if; Set_Component_Associations (Aggregate_Node, Assoc_List); + + -- Inside_Delta_Aggregate is only tested if Serious_Errors = 0, so + -- it is ok if we fail to restore the saved I_D_A value in an error + -- path. In particular, it is ok that we do not restore it if + -- Error_Resync is propagated. Earlier return statements (which return + -- without restoring the saved I_D_A value) should either be in error + -- paths or in paths where I_D_A could not have been modified. + + Inside_Delta_Aggregate := Saved_Delta_Aggregate_Flag; + return Aggregate_Node; end P_Aggregate_Or_Paren_Expr; @@ -2519,6 +2532,109 @@ package body Ch4 is Expr_Form := EF_Simple; end if; + -- If all extensions are enabled and we have a deep delta aggregate + -- whose type is an array type with an element type that is a + -- record type, then we can encounter legal things like + -- with delta (Some_Index_Expression).Some_Component + -- where a parenthesized expression precedes a dot. + -- Similarly, if the element type is an array type then we can see + -- with delta (Some_Index_Expression)(Another_Index_Expression) + -- where a parenthesized expression precedes a left parenthesis. + + if Token in Tok_Dot | Tok_Left_Paren + and then Prev_Token = Tok_Right_Paren + and then Serious_Errors_Detected = 0 + and then Inside_Delta_Aggregate + and then All_Extensions_Allowed + then + if Token = Tok_Dot then + Node2 := New_Node (N_Selected_Component, Token_Ptr); + Scan; -- past dot + declare + Tail : constant Node_Id := P_Simple_Expression; + -- remaining selectors occurring after the dot + + Rover : Node_Id := Tail; + Prev : Node_Id := Empty; + begin + -- If Tail already has a prefix, then we want to prepend + -- Node1 onto that prefix and then return Tail. + -- Otherwise, Tail should simply be an identifier so + -- we want to build a Selected_Component with Tail as the + -- selector name and return that. + + Set_Prefix (Node2, Node1); + + while Nkind (Rover) + in N_Indexed_Component | N_Selected_Component loop + Prev := Rover; + Rover := Prefix (Rover); + end loop; + + case Nkind (Prev) is + when N_Selected_Component | N_Indexed_Component => + -- We've scanned a dot, so an identifier should follow + if Nkind (Prefix (Prev)) = N_Identifier then + Set_Selector_Name (Node2, Prefix (Prev)); + Set_Prefix (Prev, Node2); + return Tail; + end if; + + when N_Empty => + -- We've scanned a dot, so an identifier should follow + if Nkind (Tail) = N_Identifier then + Set_Selector_Name (Node2, Tail); + return Node2; + end if; + + when others => + null; + end case; + + -- fall through to error case + end; + else + Node2 := New_Node (N_Indexed_Component, Token_Ptr); + declare + Tail : constant Node_Id := P_Simple_Expression; + -- remaining selectors + + Rover : Node_Id := Tail; + Prev : Node_Id := Empty; + begin + -- If Tail already has a prefix, then we want to prepend + -- Node1 onto that prefix and then return Tail. + -- Otherwise, Tail should be an index expression and + -- we want to build an Indexed_Component with Tail as the + -- index value and return that. + + Set_Prefix (Node2, Node1); + + while Nkind (Rover) + in N_Indexed_Component | N_Selected_Component loop + Prev := Rover; + Rover := Prefix (Rover); + end loop; + + case Nkind (Prev) is + when N_Selected_Component | N_Indexed_Component => + Set_Expressions (Node2, New_List (Prefix (Prev))); + Set_Prefix (Prev, Node2); + return Tail; + + when N_Empty => + Set_Expressions (Node2, New_List (Tail)); + return Node2; + + when others => + null; + end case; + + -- fall through to error case + end; + end if; + end if; + -- Come here at end of simple expression, where we do a couple of -- special checks to improve error recovery. @@ -2529,8 +2645,8 @@ package body Ch4 is if Token = Tok_Dot then Error_Msg_SC ("prefix for selection is not a name"); - -- If qualified expression, comment and continue, otherwise something - -- is pretty nasty so do an Error_Resync call. + -- If qualified expression, comment and continue, otherwise + -- something is pretty nasty so do an Error_Resync call. if Ada_Version < Ada_2012 and then Nkind (Node1) = N_Qualified_Expression |