diff options
Diffstat (limited to 'gcc/ada/sem_prag.adb')
| -rw-r--r-- | gcc/ada/sem_prag.adb | 171 |
1 files changed, 161 insertions, 10 deletions
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 2c9d518f670..369376ad555 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -505,6 +505,10 @@ package body Sem_Prag is -- Check the specified argument Arg to make sure that it is a valid -- locking policy name. If not give error and raise Pragma_Exit. + procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id); + -- Check the specified argument Arg to make sure that it is a valid + -- elaboration policy name. If not give error and raise Pragma_Exit. + procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id); @@ -778,6 +782,10 @@ package body Sem_Prag is -- Called for all GNAT defined pragmas to check the relevant restriction -- (No_Implementation_Pragmas). + procedure S14_Pragma; + -- Called for all pragmas defined for formal verification to check that + -- the S14_Extensions flag is set. + function Is_Before_First_Decl (Pragma_Node : Node_Id; Decls : List_Id) return Boolean; @@ -1190,6 +1198,22 @@ package body Sem_Prag is end if; end Check_Arg_Is_Locking_Policy; + ----------------------------------------------- + -- Check_Arg_Is_Partition_Elaboration_Policy -- + ----------------------------------------------- + + procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); + + begin + Check_Arg_Is_Identifier (Argx); + + if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then + Error_Pragma_Arg + ("& is not a valid partition elaboration policy name", Argx); + end if; + end Check_Arg_Is_Partition_Elaboration_Policy; + ------------------------- -- Check_Arg_Is_One_Of -- ------------------------- @@ -1260,6 +1284,7 @@ package body Sem_Prag is Error_Pragma_Arg ("invalid argument for pragma%", Argx); end if; end Check_Arg_Is_One_Of; + --------------------------------- -- Check_Arg_Is_Queuing_Policy -- --------------------------------- @@ -6399,6 +6424,17 @@ package body Sem_Prag is end if; end Set_Ravenscar_Profile; + ---------------- + -- S14_Pragma -- + ---------------- + + procedure S14_Pragma is + begin + if not Formal_Extensions then + Error_Pragma ("pragma% requires the use of debug switch -gnatd.V"); + end if; + end S14_Pragma; + -- Start of processing for Analyze_Pragma begin @@ -6759,19 +6795,30 @@ package body Sem_Prag is end if; end Annotate; - ------------ - -- Assert -- - ------------ + --------------------------- + -- Assert/Assert_And_Cut -- + --------------------------- + + -- pragma Assert + -- ( [Check => ] Boolean_EXPRESSION + -- [, [Message =>] Static_String_EXPRESSION]); - -- pragma Assert ([Check =>] Boolean_EXPRESSION - -- [, [Message =>] Static_String_EXPRESSION]); + -- pragma Assert_And_Cut + -- ( [Check => ] Boolean_EXPRESSION + -- [, [Message =>] Static_String_EXPRESSION]); - when Pragma_Assert => Assert : declare + when Pragma_Assert | Pragma_Assert_And_Cut => Assert : declare Expr : Node_Id; Newa : List_Id; begin - Ada_2005_Pragma; + if Prag_Id = Pragma_Assert then + Ada_2005_Pragma; + else -- Pragma_Assert_And_Cut + GNAT_Pragma; + S14_Pragma; + end if; + Check_At_Least_N_Arguments (1); Check_At_Most_N_Arguments (2); Check_Arg_Order ((Name_Check, Name_Message)); @@ -6784,6 +6831,13 @@ package body Sem_Prag is -- So rewrite pragma in this manner, transfer the message -- argument if present, and analyze the result + -- Pragma Assert_And_Cut is treated exactly like pragma Assert by + -- the frontend. Formal verification tools may use it to "cut" the + -- paths through the code, to make verification tractable. When + -- dealing with a semantically analyzed tree, the information that + -- a Check node N corresponds to a source Assert_And_Cut pragma + -- can be retrieved from the pragma kind of Original_Node(N). + Expr := Get_Pragma_Arg (Arg1); Newa := New_List ( Make_Pragma_Argument_Association (Loc, @@ -6865,6 +6919,53 @@ package body Sem_Prag is Assume_No_Invalid_Values := False; end if; + -------------------------- + -- Attribute_Definition -- + -------------------------- + + -- pragma Attribute_Definition + -- ([Attribute =>] ATTRIBUTE_DESIGNATOR, + -- [Entity =>] LOCAL_NAME, + -- [Expression =>] EXPRESSION | NAME); + + when Pragma_Attribute_Definition => Attribute_Definition : declare + Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1); + Aname : Name_Id; + + begin + GNAT_Pragma; + Check_Arg_Count (3); + Check_Optional_Identifier (Arg1, "attribute"); + Check_Optional_Identifier (Arg2, "entity"); + Check_Optional_Identifier (Arg3, "expression"); + + if Nkind (Attribute_Designator) /= N_Identifier then + Error_Msg_N ("attribute name expected", Attribute_Designator); + return; + end if; + + Check_Arg_Is_Local_Name (Arg2); + + -- If the attribute is not recognized, then issue a warning (not + -- an error), and ignore the pragma. + + Aname := Chars (Attribute_Designator); + + if not Is_Attribute_Name (Aname) then + Bad_Attribute (Attribute_Designator, Aname, Warn => True); + return; + end if; + + -- Otherwise, rewrite the pragma as an attribute definition clause + + Rewrite (N, + Make_Attribute_Definition_Clause (Loc, + Name => Get_Pragma_Arg (Arg2), + Chars => Aname, + Expression => Get_Pragma_Arg (Arg3))); + Analyze (N); + end Attribute_Definition; + --------------- -- AST_Entry -- --------------- @@ -12022,6 +12123,53 @@ package body Sem_Prag is when Pragma_Page => null; + ---------------------------------- + -- Partition_Elaboration_Policy -- + ---------------------------------- + + -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER); + + when Pragma_Partition_Elaboration_Policy => declare + subtype PEP_Range is Name_Id + range First_Partition_Elaboration_Policy_Name + .. Last_Partition_Elaboration_Policy_Name; + PEP_Val : PEP_Range; + PEP : Character; + + begin + Ada_2005_Pragma; + Check_Arg_Count (1); + Check_No_Identifiers; + Check_Arg_Is_Partition_Elaboration_Policy (Arg1); + Check_Valid_Configuration_Pragma; + PEP_Val := Chars (Get_Pragma_Arg (Arg1)); + + case PEP_Val is + when Name_Concurrent => + PEP := 'C'; + when Name_Sequential => + PEP := 'S'; + end case; + + if Partition_Elaboration_Policy /= ' ' + and then Partition_Elaboration_Policy /= PEP + then + Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc; + Error_Pragma + ("partition elaboration policy incompatible with policy#"); + + -- Set new policy, but always preserve System_Location since we + -- like the error message with the run time name. + + else + Partition_Elaboration_Policy := PEP; + + if Partition_Elaboration_Policy_Sloc /= System_Location then + Partition_Elaboration_Policy_Sloc := Loc; + end if; + end if; + end; + ------------- -- Passive -- ------------- @@ -13669,9 +13817,9 @@ package body Sem_Prag is end; end Stream_Convert; - ------------------------- - -- Style_Checks (GNAT) -- - ------------------------- + ------------------ + -- Style_Checks -- + ------------------ -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); @@ -15185,8 +15333,10 @@ package body Sem_Prag is Pragma_All_Calls_Remote => -1, Pragma_Annotate => -1, Pragma_Assert => -1, + Pragma_Assert_And_Cut => -1, Pragma_Assertion_Policy => 0, Pragma_Assume_No_Invalid_Values => 0, + Pragma_Attribute_Definition => +3, Pragma_Asynchronous => -1, Pragma_Atomic => 0, Pragma_Atomic_Components => 0, @@ -15294,6 +15444,7 @@ package body Sem_Prag is Pragma_Ordered => 0, Pragma_Pack => 0, Pragma_Page => -1, + Pragma_Partition_Elaboration_Policy => -1, Pragma_Passive => -1, Pragma_Preelaborable_Initialization => -1, Pragma_Polling => -1, |