From f02b8bb877f4e1000c92df67b4a8b5b1efc263bd Mon Sep 17 00:00:00 2001 From: Robert Dewar Date: Tue, 15 Nov 2005 14:51:09 +0100 Subject: re PR ada/18434 (Ada: cannot build gnattools on Tru64 UNIX V5.1B) 2005-11-14 Robert Dewar Ed Schonberg PR ada/18434 * types.ads: Include All_Checks in Suppress_Array * checks.adb (Check_Needed): Remove kludge for a/=b rewritten as not(a=b), since we no longer do this rewriting, and hence it is not needed. (Elaboration_Checks_Suppressed): Add special casing to deal with different cases of static and dynamic elaboration checks (all checks does not count in the first case, but does in the second). (Expr_Known_Valid): Do not assume that the result of any arbitrary function call is valid, since this is not the case. (Ensure_Valid): Do not apply validity check to a real literal in a universal or fixed context * exp_ch4.adb (Expand_N_Op_Ne): Don't expand a/=b to not(a=b) for elementary types using the operator in standard. It is cleaner not to modify the programmers intent, especially in the case of floating-point. (Rewrite_Comparison): Fix handling of /= (this was always wrong, but it did not matter because we always rewrote a/=b to not(a=b). (Expand_Allocator_Expression): For an allocator expression whose nominal subtype is an unconstrained packed type, convert the expression to its actual constrained subtype. Implement warning for <= or >= where < or > not possible Fix to Vax_Float tests (too early in many routines, causing premature Vax_Float expansions. * sem_prag.adb (Analyze_Pragma, case Obsolescent): Allow this pragma to be used with packages and generic packages as well as with subprograms. (Suppress): Set All_Checks, but not Elaboration_Check, for case of pragma Suppress (All_Checks) (Analyze_Pragma, case Warnings): Implement first argument allowed to be a string literal for precise control over warnings. Avoid raise of pragma in case of unrecognized pragma and just return instead. * sem_prag.ads: Minor reformatting * switch-c.adb (Scan_Front_End_Switches): Replace "raise Bad_Switch;" with call to new procedure Bad_Switch. Call Scan_Pos with new parameter Switch. Do not handle any exception. Include -gnatwx as part of -gnatg (warn on redundant parens) Allow optional = after -gnatm (Scan_Front_End_Switches): The -gnatp switch sets All_Checks, but no longer sets Elaboration_Checks. Code to set warning mode moved to Sem_Warn so that it can be shared by pragma processing. * s-mastop-tru64.adb (Pop_Frame): Remove redundant parentheses in if statement. * s-taprop-solaris.adb: Change some <= to =, to avoid new warning * a-exexda.adb, prj-proc.adb: Fix obvious typo (Num_Tracebacks compared <= 0 instead of < 0) Fix obvious typo (Total_Errors_Detected <= 0 should be = 0) From-SVN: r106950 --- gcc/ada/sem_prag.adb | 138 +++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 107 insertions(+), 31 deletions(-) (limited to 'gcc/ada/sem_prag.adb') diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 29233a4..b06f117 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -64,6 +64,7 @@ with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sem_VFpt; use Sem_VFpt; +with Sem_Warn; use Sem_Warn; with Stand; use Stand; with Sinfo; use Sinfo; with Sinfo.CN; use Sinfo.CN; @@ -236,8 +237,9 @@ package body Sem_Prag is Pragma_Exit : exception; -- This exception is used to exit pragma processing completely. It - -- is used when an error is detected, and in other situations where - -- it is known that no further processing is required. + -- is used when an error is detected, and no further processing is + -- required. It is also used if an earlier error has left the tree + -- in a state where the pragma should not be processed. Arg_Count : Nat; -- Number of pragma argument associations @@ -1331,15 +1333,12 @@ package body Sem_Prag is Analyze (Expression (Arg1)); - if Unit_Kind = N_Generic_Subprogram_Declaration + if Unit_Kind = N_Generic_Subprogram_Declaration or else Unit_Kind = N_Subprogram_Declaration then Unit_Name := Defining_Entity (Unit_Node); - elsif Unit_Kind = N_Function_Instantiation - or else Unit_Kind = N_Package_Instantiation - or else Unit_Kind = N_Procedure_Instantiation - then + elsif Unit_Kind in N_Generic_Instantiation then Unit_Name := Defining_Entity (Unit_Node); else @@ -2141,7 +2140,7 @@ package body Sem_Prag is and then Ekind (E) /= E_Variable and then not (Is_Access_Type (E) - and then Ekind (Designated_Type (E)) = E_Subprogram_Type) + and then Ekind (Designated_Type (E)) = E_Subprogram_Type) then Error_Pragma_Arg ("second argument of pragma% must be subprogram (type)", @@ -3784,9 +3783,21 @@ package body Sem_Prag is -- suppress check for any check id value. if C = All_Checks then + + -- For All_Checks, we set all specific checks with the + -- exception of Elaboration_Check, which is handled specially + -- because of not wanting All_Checks to have the effect of + -- deactivating static elaboration order processing. + for J in Scope_Suppress'Range loop - Scope_Suppress (J) := Suppress_Case; + if J /= Elaboration_Check then + Scope_Suppress (J) := Suppress_Case; + end if; end loop; + + -- If not All_Checks, just set appropriate entry. Note that we + -- will set Elaboration_Check if this is explicitly specified. + else Scope_Suppress (C) := Suppress_Case; end if; @@ -4259,7 +4270,7 @@ package body Sem_Prag is if Warn_On_Unrecognized_Pragma then Error_Pragma ("unrecognized pragma%!?"); else - raise Pragma_Exit; + return; end if; else Prag_Id := Get_Pragma_Id (Chars (N)); @@ -5885,7 +5896,7 @@ package body Sem_Prag is Error_Pragma ("pragma% must refer to a spec, not a body"); else Set_Body_Required (Cunit_Node, True); - Set_Has_Pragma_Elaborate_Body (Cunit_Ent); + Set_Has_Pragma_Elaborate_Body (Cunit_Ent); -- If we are in dynamic elaboration mode, then we suppress -- elaboration warnings for the unit, since it is definitely @@ -5991,7 +6002,7 @@ package body Sem_Prag is Present (Source_Location) then Error_Pragma - ("parameter profile and source location can not " & + ("parameter profile and source location cannot " & "be used together in pragma%"); end if; @@ -8141,6 +8152,28 @@ package body Sem_Prag is S : String_Id; Active : Boolean := True; + procedure Check_Obsolete_Subprogram; + -- Checks if Subp is a subprogram declaration node, and if so + -- replaces Subp by the defining entity of the subprogram. If not, + -- issues an error message + + ------------------------------ + -- Check_Obsolete_Subprogram-- + ------------------------------ + + procedure Check_Obsolete_Subprogram is + begin + if Nkind (Subp) /= N_Subprogram_Declaration then + Error_Pragma + ("pragma% misplaced, must immediately " & + "follow subprogram/package declaration"); + else + Subp := Defining_Entity (Subp); + end if; + end Check_Obsolete_Subprogram; + + -- Start of processing for pragma Obsolescent + begin GNAT_Pragma; Check_At_Most_N_Arguments (2); @@ -8153,6 +8186,7 @@ package body Sem_Prag is if Present (Prev (N)) then Subp := Prev (N); + Check_Obsolete_Subprogram; -- Second possibility, stand alone subprogram declaration with the -- pragma immediately following the declaration. @@ -8161,25 +8195,22 @@ package body Sem_Prag is and then Nkind (Parent (N)) = N_Compilation_Unit_Aux then Subp := Unit (Parent (Parent (N))); + Check_Obsolete_Subprogram; - -- Any other possibility is a misplacement + -- Only other possibility is library unit placement for package else - Subp := Empty; - end if; - - -- Check correct placement + Subp := Find_Lib_Unit_Name; - if Nkind (Subp) /= N_Subprogram_Declaration then - Error_Pragma - ("pragma% misplaced, must immediately " & - "follow subprogram spec"); + if Ekind (Subp) /= E_Package + and then Ekind (Subp) /= E_Generic_Package + then + Check_Obsolete_Subprogram; + end if; end if; -- If OK placement, acquire arguments - Subp := Defining_Entity (Subp); - if Arg_Count >= 1 then -- Deal with static string argument @@ -9907,8 +9938,7 @@ package body Sem_Prag is ("pragma% requires separate spec and must come before body"); elsif Rep_Item_Too_Early (E, N) - or else - Rep_Item_Too_Late (E, N) + or else Rep_Item_Too_Late (E, N) then raise Pragma_Exit; @@ -10346,16 +10376,58 @@ package body Sem_Prag is -------------- -- pragma Warnings (On | Off, [LOCAL_NAME]) + -- pragma Warnings (static_string_EXPRESSION); when Pragma_Warnings => Warnings : begin GNAT_Pragma; Check_At_Least_N_Arguments (1); - Check_At_Most_N_Arguments (2); Check_No_Identifiers; - -- One argument case was processed by parser in Par.Prag + -- One argument case - if Arg_Count /= 1 then + if Arg_Count = 1 then + declare + Argx : constant Node_Id := Get_Pragma_Arg (Arg1); + + begin + -- On/Off one argument case was processed by parser + + if Nkind (Argx) = N_Identifier + and then + (Chars (Argx) = Name_On + or else + Chars (Argx) = Name_Off) + then + null; + + else + Check_Arg_Is_Static_Expression (Arg1, Standard_String); + + declare + Lit : constant Node_Id := Expr_Value_S (Argx); + Str : constant String_Id := Strval (Lit); + C : Char_Code; + + begin + for J in 1 .. String_Length (Str) loop + C := Get_String_Char (Str, J); + + if In_Character_Range (C) + and then Set_Warning_Switch (Get_Character (C)) + then + null; + else + Error_Pragma_Arg + ("invalid warning switch character", Arg1); + end if; + end loop; + end; + end if; + end; + + -- Two argument case + + elsif Arg_Count /= 1 then Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); Check_Arg_Count (2); @@ -10372,7 +10444,7 @@ package body Sem_Prag is -- is a conversion. Retrieve the real entity name. if (In_Instance_Body - or else In_Inlined_Body) + or else In_Inlined_Body) and then Nkind (E_Id) = N_Unchecked_Type_Conversion then E_Id := Expression (E_Id); @@ -10390,8 +10462,8 @@ package body Sem_Prag is return; else loop - Set_Warnings_Off (E, - (Chars (Expression (Arg1)) = Name_Off)); + Set_Warnings_Off + (E, (Chars (Expression (Arg1)) = Name_Off)); if Is_Enumeration_Type (E) then declare @@ -10410,6 +10482,10 @@ package body Sem_Prag is end loop; end if; end; + + -- More than two arguments + else + Check_At_Most_N_Arguments (2); end if; end Warnings; -- cgit v1.1