diff options
Diffstat (limited to 'gcc/ada/sem_prag.adb')
| -rw-r--r-- | gcc/ada/sem_prag.adb | 142 |
1 files changed, 121 insertions, 21 deletions
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 8501a71c72c..0d8c1e1861e 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -244,6 +244,12 @@ package body Sem_Prag is -- in which case the check is applied to the expression of the -- association or an expression directly. + procedure Check_Arg_Is_External_Name (Arg : Node_Id); + -- Check that an argument has the right form for an EXTERNAL_NAME + -- parameter of an extended import/export pragma. The rule is that + -- the name must be an identifier or string literal (in Ada 83 mode) + -- or a static string expression (in Ada 95 mode). + procedure Check_Arg_Is_Identifier (Arg : Node_Id); -- Check the specified argument Arg to make sure that it is an -- identifier. If not give error and raise Pragma_Exit. @@ -589,13 +595,61 @@ package body Sem_Prag is end if; end Check_Arg_Count; + -------------------------------- + -- Check_Arg_Is_External_Name -- + -------------------------------- + + procedure Check_Arg_Is_External_Name (Arg : Node_Id) is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); + + begin + if Nkind (Argx) = N_Identifier then + return; + + else + Analyze_And_Resolve (Argx, Standard_String); + + if Is_OK_Static_Expression (Argx) then + return; + + elsif Etype (Argx) = Any_Type then + raise Pragma_Exit; + + -- An interesting special case, if we have a string literal and + -- we are in Ada 83 mode, then we allow it even though it will + -- not be flagged as static. This allows expected Ada 83 mode + -- use of external names which are string literals, even though + -- technically these are not static in Ada 83. + + elsif Ada_Version = Ada_83 + and then Nkind (Argx) = N_String_Literal + then + return; + + -- Static expression that raises Constraint_Error. This has + -- already been flagged, so just exit from pragma processing. + + elsif Is_Static_Expression (Argx) then + raise Pragma_Exit; + + -- Here we have a real error (non-static expression) + + else + Error_Msg_Name_1 := Chars (N); + Flag_Non_Static_Expr + ("argument for pragma% must be a identifier or " & + "static string expression!", Argx); + raise Pragma_Exit; + end if; + end if; + end Check_Arg_Is_External_Name; + ----------------------------- -- Check_Arg_Is_Identifier -- ----------------------------- procedure Check_Arg_Is_Identifier (Arg : Node_Id) is Argx : constant Node_Id := Get_Pragma_Arg (Arg); - begin if Nkind (Argx) /= N_Identifier then Error_Pragma_Arg @@ -609,7 +663,6 @@ package body Sem_Prag is procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is Argx : constant Node_Id := Get_Pragma_Arg (Arg); - begin if Nkind (Argx) /= N_Integer_Literal then Error_Pragma_Arg @@ -2084,13 +2137,8 @@ package body Sem_Prag is Set_Extended_Import_Export_External_Name (Def_Id, Arg_External); - if Present (Arg_Size) - and then Nkind (Arg_Size) /= N_Identifier - and then Nkind (Arg_Size) /= N_String_Literal - then - Error_Pragma_Arg - ("pragma% Size argument must be identifier or string literal", - Arg_Size); + if Present (Arg_Size) then + Check_Arg_Is_External_Name (Arg_Size); end if; -- Export_Object case @@ -3271,7 +3319,8 @@ package body Sem_Prag is Val : Uint; procedure Set_Warning (R : All_Restrictions); - -- If this is a Restriction_Warnings pragma, set warning flag + -- If this is a Restriction_Warnings pragma, set warning flag, + -- otherwise reset the flag. ----------------- -- Set_Warning -- @@ -3281,6 +3330,8 @@ package body Sem_Prag is begin if Prag_Id = Pragma_Restriction_Warnings then Restriction_Warnings (R) := True; + else + Restriction_Warnings (R) := False; end if; end Set_Warning; @@ -3306,7 +3357,7 @@ package body Sem_Prag is R_Id := Get_Restriction_Id - (Process_Restriction_Synonyms (Chars (Expr))); + (Process_Restriction_Synonyms (Expr)); if R_Id not in All_Boolean_Restrictions then Error_Pragma_Arg @@ -3334,7 +3385,7 @@ package body Sem_Prag is -- Case of restriction identifier present else - R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Id)); + R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg)); Analyze_And_Resolve (Expr, Any_Integer); if R_Id not in All_Parameter_Restrictions then @@ -3609,8 +3660,11 @@ package body Sem_Prag is begin if No (Arg_External) then return; + end if; + + Check_Arg_Is_External_Name (Arg_External); - elsif Nkind (Arg_External) = N_String_Literal then + if Nkind (Arg_External) = N_String_Literal then if String_Length (Strval (Arg_External)) = 0 then return; else @@ -3620,10 +3674,12 @@ package body Sem_Prag is elsif Nkind (Arg_External) = N_Identifier then New_Name := Get_Default_External_Name (Arg_External); + -- Check_Arg_Is_External_Name should let through only + -- identifiers and string literals or static string + -- expressions (which are folded to string literals). + else - Error_Pragma_Arg - ("incorrect form for External parameter for pragma%", - Arg_External); + raise Program_Error; end if; -- If we already have an external name set (by a prior normal @@ -3848,7 +3904,7 @@ package body Sem_Prag is -- Set Detect_Blocking mode ??? - -- Set required restrictions (see Restrict.Set_Ravenscar for details) + -- Set required restrictions (see System.Rident for detailed list) procedure Set_Ravenscar_Profile (N : Node_Id) is begin @@ -3896,7 +3952,7 @@ package body Sem_Prag is -- Set the corresponding restrictions - Set_Ravenscar (N); + Set_Profile_Restrictions (Ravenscar, N, Warn => False); end Set_Ravenscar_Profile; -- Start of processing for Analyze_Pragma @@ -8095,10 +8151,9 @@ package body Sem_Prag is -- pragma Profile (profile_IDENTIFIER); - -- profile_IDENTIFIER => Ravenscar + -- profile_IDENTIFIER => Protected | Ravenscar when Pragma_Profile => - GNAT_Pragma; Check_Arg_Count (1); Check_Valid_Configuration_Pragma; Check_No_Identifiers; @@ -8108,6 +8163,36 @@ package body Sem_Prag is begin if Chars (Argx) = Name_Ravenscar then Set_Ravenscar_Profile (N); + + elsif Chars (Argx) = Name_Restricted then + Set_Profile_Restrictions (Restricted, N, Warn => False); + else + Error_Pragma_Arg ("& is not a valid profile", Argx); + end if; + end; + + ---------------------- + -- Profile_Warnings -- + ---------------------- + + -- pragma Profile_Warnings (profile_IDENTIFIER); + + -- profile_IDENTIFIER => Protected | Ravenscar + + when Pragma_Profile_Warnings => + GNAT_Pragma; + Check_Arg_Count (1); + Check_Valid_Configuration_Pragma; + Check_No_Identifiers; + + declare + Argx : constant Node_Id := Get_Pragma_Arg (Arg1); + begin + if Chars (Argx) = Name_Ravenscar then + Set_Profile_Restrictions (Ravenscar, N, Warn => True); + + elsif Chars (Argx) = Name_Restricted then + Set_Profile_Restrictions (Restricted, N, Warn => True); else Error_Pragma_Arg ("& is not a valid profile", Argx); end if; @@ -8579,6 +8664,13 @@ package body Sem_Prag is Check_Valid_Configuration_Pragma; Set_Ravenscar_Profile (N); + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("pragma Ravenscar is an obsolescent feature?", N); + Error_Msg_N + ("|use pragma Profile (Ravenscar) instead", N); + end if; + ------------------------- -- Restricted_Run_Time -- ------------------------- @@ -8589,7 +8681,14 @@ package body Sem_Prag is GNAT_Pragma; Check_Arg_Count (0); Check_Valid_Configuration_Pragma; - Set_Restricted_Profile (N); + Set_Profile_Restrictions (Restricted, N, Warn => False); + + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("pragma Restricted_Run_Time is an obsolescent feature?", N); + Error_Msg_N + ("|use pragma Profile (Restricted) instead", N); + end if; ------------------ -- Restrictions -- @@ -10158,6 +10257,7 @@ package body Sem_Prag is Pragma_Preelaborate => -1, Pragma_Priority => -1, Pragma_Profile => 0, + Pragma_Profile_Warnings => 0, Pragma_Propagate_Exceptions => -1, Pragma_Psect_Object => -1, Pragma_Pure => 0, |