diff options
Diffstat (limited to 'gcc/ada/sem_prag.adb')
| -rw-r--r-- | gcc/ada/sem_prag.adb | 182 |
1 files changed, 182 insertions, 0 deletions
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index c391e27..b9172cd 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -26343,6 +26343,187 @@ package body Sem_Prag is Check_Valid_Configuration_Pragma; Use_VADS_Size := True; + ---------------------------- + -- User_Aspect_Definition -- + ---------------------------- + + -- pragma User_Aspect_Definition + -- (Identifier, {, Identifier [(Identifier {, Identifier})]}); + + when Pragma_User_Aspect_Definition => + GNAT_Pragma; + Check_Valid_Configuration_Pragma; + declare + Arg : Node_Id := + First (Pragma_Argument_Associations (N)); + User_Aspect_Name : constant Name_Id := Chars (Expression (Arg)); + Expr : Node_Id; + Aspect : Aspect_Id; + begin + if Get_Aspect_Id (User_Aspect_Name) /= No_Aspect then + Error_Pragma_Arg + ("User-defined aspect name for pragma% is the name " & + "of an existing aspect", Arg); + end if; + + Next (Arg); -- skip first argument, the name of the aspect + + while Present (Arg) loop + Expr := Expression (Arg); + case Nkind (Expr) is + when N_Identifier => + Aspect := Get_Aspect_Id (Chars (Expr)); + if Aspect in Boolean_Aspects + and not Is_Representation_Aspect (Aspect) + then + -- If we allowed representation aspects such as + -- Pack here, then User_Aspect itself would need + -- to be a representation aspect. + + null; + elsif Aspect = No_Aspect and then + Present (User_Aspect_Support.Registered_UAD_Pragma + (User_Aspect_Name)) + then + null; + else + Error_Pragma_Arg + ("unparameterized argument for pragma% must be " & + "either a Boolean-valued non-representation " & + "aspect or user-defined", Arg); + end if; + when N_Indexed_Component => + Aspect := Get_Aspect_Id (Chars (Prefix (Expr))); + + -- Aspect should be an aspect that takes + -- identifier arguments that do not refer to + -- declarations, but rather to undeclared entities + -- such as GNATProve or No_Secondary_Stack for + -- which the notion of visibility does not apply. + + case Aspect is + when Aspect_Annotate => + if List_Length (Expressions (Expr)) /= 2 then + Error_Pragma_Arg + ("Annotate argument for pragma% takes " & + "two parameters", Arg); + end if; + + when Aspect_Local_Restrictions => + null; + + when others => + Error_Pragma_Arg + ("parameterized argument for pragma% must be " & + "Annotate or Local_Restrictions aspect", Arg); + end case; + when others => + raise Program_Error; -- parsing error + end case; + Next (Arg); + end loop; + + declare + Registered : constant Node_Id := + User_Aspect_Support.Registered_UAD_Pragma + (User_Aspect_Name); + + -- Given two User_Aspect_Definition pragmas with + -- matching names for the first argument, check that + -- subsequent arguments also match; complain if they differ. + procedure Check_UAD_Conformance + (New_Pragma, Old_Pragma : Node_Id); + + --------------------------- + -- Check_UAD_Conformance -- + --------------------------- + + procedure Check_UAD_Conformance + (New_Pragma, Old_Pragma : Node_Id) + is + Old_Arg : Node_Id := + First (Pragma_Argument_Associations (Old_Pragma)); + New_Arg : Node_Id := + First (Pragma_Argument_Associations (New_Pragma)); + OK : Boolean := True; + + function Same_Chars (Id1, Id2 : Node_Id) return Boolean + is (Chars (Id1) = Chars (Id2)); + + function Same_Identifier_List (Id1, Id2 : Node_Id) + return Boolean + is (if No (Id1) and No (Id2) then True + elsif No (Id1) or No (Id2) then False + else (Same_Chars (Id1, Id2) and then + Same_Identifier_List (Next (Id1), Next (Id2)))); + begin + -- We could skip the first argument pair since those + -- are already known to match (or we wouldn't be + -- calling this procedure). + + while Present (Old_Arg) or Present (New_Arg) loop + if Present (Old_Arg) /= Present (New_Arg) then + OK := False; + elsif Nkind (Expression (Old_Arg)) /= + Nkind (Expression (New_Arg)) + then + OK := False; + else + case Nkind (Expression (Old_Arg)) is + when N_Identifier => + OK := Same_Chars (Expression (Old_Arg), + Expression (New_Arg)); + + when N_Indexed_Component => + OK := Same_Chars + (Prefix (Expression (Old_Arg)), + Prefix (Expression (New_Arg))) + and then Same_Identifier_List + (First (Expressions + (Expression (Old_Arg))), + First (Expressions + (Expression (New_Arg)))); + + when others => + OK := False; + pragma Assert (False); + end case; + end if; + + if not OK then + Error_Msg_Sloc := Sloc (Old_Pragma); + Error_Msg_N + ("Nonconforming definitions for user-defined " & + "aspect #", New_Pragma); + return; + end if; + + Next (Old_Arg); + Next (New_Arg); + end loop; + end Check_UAD_Conformance; + begin + if Present (Registered) then + -- If we have already seen a UAD pragma with this name, + -- then check that the two pragmas conform (which means + -- that the new pragma is redundant and can be ignored). + + -- ??? We could also perform a similar bind-time check, + -- since it is possible that an incompatible pair of + -- UAD pragmas might not be detected by this check. + -- This could arise if no unit's compilation closure + -- includes both of the two. The major downside of + -- failing to detect this case is possible confusion + -- for human readers. + + Check_UAD_Conformance (New_Pragma => N, + Old_Pragma => Registered); + else + User_Aspect_Support.Register_UAD_Pragma (N); + end if; + end; + end; + --------------------- -- Validity_Checks -- --------------------- @@ -32675,6 +32856,7 @@ package body Sem_Prag is Pragma_Unsuppress => 0, Pragma_Unused => 0, Pragma_Use_VADS_Size => 0, + Pragma_User_Aspect_Definition => 0, Pragma_Validity_Checks => 0, Pragma_Volatile => 0, Pragma_Volatile_Components => 0, |