diff options
| -rw-r--r-- | gcc/ada/exp_prag.adb | 25 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 61 | ||||
| -rw-r--r-- | gcc/ada/snames.ads-tmpl | 1 | ||||
| -rw-r--r-- | gcc/testsuite/gnat.dg/loopvar.adb | 2 |
4 files changed, 64 insertions, 25 deletions
diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 0fe8bff..bf2d297 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -2694,10 +2694,15 @@ package body Exp_Prag is -- If pragma is not enabled, rewrite as Null statement. If pragma is -- disabled, it has already been rewritten as a Null statement. -- - -- Likewise, do this in CodePeer mode, because the expanded code is too + -- Likewise, ignore structural variants for execution. + -- + -- Also do this in CodePeer mode, because the expanded code is too -- complicated for CodePeer to analyse. - if Is_Ignored (N) or else CodePeer_Mode then + if Is_Ignored (N) + or else Chars (Last_Var) = Name_Structural + or else CodePeer_Mode + then Rewrite (N, Make_Null_Statement (Loc)); Analyze (N); return; @@ -3058,10 +3063,12 @@ package body Exp_Prag is Loc : constant Source_Ptr := Sloc (Prag); - Aggr : Node_Id; + Aggr : constant Node_Id := + Expression (First (Pragma_Argument_Associations (Prag))); Formal_Map : Elist_Id; Last : Node_Id; - Last_Variant : Node_Id; + Last_Variant : constant Node_Id := + Nlists.Last (Component_Associations (Aggr)); Proc_Bod : Node_Id; Proc_Decl : Node_Id; Proc_Id : Entity_Id; @@ -3069,14 +3076,15 @@ package body Exp_Prag is Variant : Node_Id; begin - -- Do nothing if pragma is not present or is disabled + -- Do nothing if pragma is not present or is disabled. + -- Also ignore structural variants for execution. - if Is_Ignored (Prag) then + if Is_Ignored (Prag) + or else Chars (Nlists.Last (Choices (Last_Variant))) = Name_Structural + then return; end if; - Aggr := Expression (First (Pragma_Argument_Associations (Prag))); - -- The expansion of Subprogram Variant is quite distributed as it -- produces various statements to capture and compare the arguments. -- To preserve the original context, set the Is_Assertion_Expr flag. @@ -3115,7 +3123,6 @@ package body Exp_Prag is Last := Proc_Decl; Curr_Decls := New_List; - Last_Variant := Nlists.Last (Component_Associations (Aggr)); Variant := First (Component_Associations (Aggr)); while Present (Variant) loop diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 9ef3a06..57a74db 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -19423,7 +19423,8 @@ package body Sem_Prag is if Chars (Variant) = No_Name then Error_Pragma_Arg_Ident ("expect name `Increases`", Variant); - elsif Chars (Variant) not in Name_Decreases | Name_Increases + elsif Chars (Variant) not in + Name_Decreases | Name_Increases | Name_Structural then declare Name : String := Get_Name_String (Chars (Variant)); @@ -19448,11 +19449,24 @@ package body Sem_Prag is Error_Pragma_Arg_Ident ("expect name `Decreases`", Variant); + elsif Name'Length >= 4 + and then Name (1 .. 4) = "stru" + then + Error_Pragma_Arg_Ident + ("expect name `Structural`", Variant); + else Error_Pragma_Arg_Ident - ("expect name `Increases` or `Decreases`", Variant); + ("expect name `Increases`, `Decreases`," + & " or `Structural`", Variant); end if; end; + + elsif Chars (Variant) = Name_Structural + and then List_Length (Pragma_Argument_Associations (N)) > 1 + then + Error_Pragma_Arg_Ident + ("Structural variant shall be the only variant", Variant); end if; -- Preanalyze_Assert_Expression, but without enforcing any of @@ -19460,9 +19474,12 @@ package body Sem_Prag is Preanalyze_Assert_Expression (Expression (Variant)); - -- Expression of a discrete type is allowed + -- Expression of a discrete type is allowed. Nothing to + -- check for structural variants. - if Is_Discrete_Type (Etype (Expression (Variant))) then + if Chars (Variant) = Name_Structural + or else Is_Discrete_Type (Etype (Expression (Variant))) + then null; -- Expression of a Big_Integer type (or its ghost variant) is @@ -24227,13 +24244,16 @@ package body Sem_Prag is -- Subprogram_Variant -- ------------------------ - -- pragma Subprogram_Variant ( SUBPROGRAM_VARIANT_ITEM - -- {, SUBPROGRAM_VARIANT_ITEM } ); - - -- SUBPROGRAM_VARIANT_ITEM ::= - -- CHANGE_DIRECTION => discrete_EXPRESSION + -- pragma Subprogram_Variant ( SUBPROGRAM_VARIANT_LIST ); - -- CHANGE_DIRECTION ::= Increases | Decreases + -- SUBPROGRAM_VARIANT_LIST ::= STRUCTURAL_SUBPROGRAM_VARIANT_ITEM + -- | NUMERIC_SUBPROGRAM_VARIANT_ITEMS + -- NUMERIC_SUBPROGRAM_VARIANT_ITEMS ::= + -- NUMERIC_SUBPROGRAM_VARIANT_ITEM + -- {, NUMERIC_SUBPROGRAM_VARIANT_ITEM} + -- NUMERIC_SUBPROGRAM_VARIANT_ITEM ::= CHANGE_DIRECTION => EXPRESSION + -- STRUCTURAL_SUBPROGRAM_VARIANT_ITEM ::= Structural => EXPRESSION + -- CHANGE_DIRECTION ::= Increases | Decreases -- Characteristics: @@ -29435,9 +29455,9 @@ package body Sem_Prag is -- Check placement of OTHERS if available (SPARK RM 6.1.3(1)) if Nkind (Direction) = N_Identifier then - if Chars (Direction) /= Name_Decreases - and then - Chars (Direction) /= Name_Increases + if Chars (Direction) not in Name_Decreases + | Name_Increases + | Name_Structural then Error_Msg_N ("wrong direction", Direction); end if; @@ -29452,9 +29472,12 @@ package body Sem_Prag is Preanalyze_Assert_Expression (Expr); - -- Expression of a discrete type is allowed + -- Expression of a discrete type is allowed. Nothing more to check + -- for structural variants. - if Is_Discrete_Type (Etype (Expr)) then + if Is_Discrete_Type (Etype (Expr)) + or else Chars (Direction) = Name_Structural + then null; -- Expression of a Big_Integer type (or its ghost variant) is only @@ -29561,6 +29584,14 @@ package body Sem_Prag is Variant := First (Component_Associations (Variants)); while Present (Variant) loop Analyze_Variant (Variant); + + if Chars (First (Choices (Variant))) = Name_Structural + and then List_Length (Component_Associations (Variants)) > 1 + then + Error_Msg_N + ("Structural variant shall be the only variant", Variant); + end if; + Next (Variant); end loop; diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index fa7ac8a..5f7d6b7 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -875,6 +875,7 @@ package Snames is Name_Static : constant Name_Id := N + $; Name_Stack_Size : constant Name_Id := N + $; Name_Strict : constant Name_Id := N + $; + Name_Structural : constant Name_Id := N + $; Name_Subunit_File_Name : constant Name_Id := N + $; Name_Suppressible : constant Name_Id := N + $; Name_Synchronous : constant Name_Id := N + $; diff --git a/gcc/testsuite/gnat.dg/loopvar.adb b/gcc/testsuite/gnat.dg/loopvar.adb index f85402a..e98d20d 100644 --- a/gcc/testsuite/gnat.dg/loopvar.adb +++ b/gcc/testsuite/gnat.dg/loopvar.adb @@ -9,7 +9,7 @@ begin pragma Loop_Variant (J + 1); -- { dg-error "expect name \"Increases\"" } pragma Loop_Variant (incr => -J + 1); -- { dg-error "expect name \"Increases\"" } pragma Loop_Variant (decr => -J + 1); -- { dg-error "expect name \"Decreases\"" } - pragma Loop_Variant (foof => -J + 1); -- { dg-error "expect name \"Increases\" or \"Decreases\"" } + pragma Loop_Variant (foof => -J + 1); -- { dg-error "expect name \"Increases\", \"Decreases\", or \"Structural\"" } J := J + 2; end loop; end Loopvar; |