From 32a21096039a8a589a9dea3c977f9d18a37a39be Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 10 Oct 2014 16:39:14 +0200 Subject: [PATCH] [multiple changes] 2014-10-10 Robert Dewar * errout.adb (Adjust_Name_Case): New procedure. (Set_Msg_Node): Use Adjust_Name_Case. * errout.ads (Adjust_Name_Case): New procedure. * exp_intr.adb (Add_Source_Info): Minor code reorganization (use Ekind_In). (Write_Entity_Name): Use Errout.Adjust_Name_Case. * sem_prag.adb (Is_Non_Significant_Pragma_Reference): Review and fix up entries in Sig_Flags, and correct logical errors in function itself. * sprint.adb (Sprint_Node_Actual): Properly print string for raise statement. 2014-10-10 Ed Schonberg * sem_ch3.adb (Analyze_Object_Declaration): For an object of an anonymous array type with delayed aspects, defer freezing of type until object itself is frozen. * freeze.adb (Freeze_Entity): When freezing an object of an anonymous array type with delayed aspects, remove freeze node of object after freezing type, to prevent out-of-order elaboration in the back-end. The initialization call for the object has already been constructed when expanding the object declaration. From-SVN: r216089 --- gcc/ada/ChangeLog | 25 +++++ gcc/ada/errout.adb | 126 ++++++++++++---------- gcc/ada/errout.ads | 18 ++-- gcc/ada/exp_intr.adb | 124 ++++++++++++++-------- gcc/ada/freeze.adb | 17 +++ gcc/ada/sem_ch3.adb | 14 ++- gcc/ada/sem_prag.adb | 241 +++++++++++++++++++++++-------------------- gcc/ada/sprint.adb | 6 ++ 8 files changed, 350 insertions(+), 221 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a621e397896..6de6c99a669 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,28 @@ +2014-10-10 Robert Dewar + + * errout.adb (Adjust_Name_Case): New procedure. + (Set_Msg_Node): Use Adjust_Name_Case. + * errout.ads (Adjust_Name_Case): New procedure. + * exp_intr.adb (Add_Source_Info): Minor code reorganization + (use Ekind_In). + (Write_Entity_Name): Use Errout.Adjust_Name_Case. + * sem_prag.adb (Is_Non_Significant_Pragma_Reference): Review + and fix up entries in Sig_Flags, and correct logical errors in + function itself. + * sprint.adb (Sprint_Node_Actual): Properly print string for + raise statement. + +2014-10-10 Ed Schonberg + + * sem_ch3.adb (Analyze_Object_Declaration): For an object of an + anonymous array type with delayed aspects, defer freezing of + type until object itself is frozen. + * freeze.adb (Freeze_Entity): When freezing an object of an + anonymous array type with delayed aspects, remove freeze node of + object after freezing type, to prevent out-of-order elaboration + in the back-end. The initialization call for the object has + already been constructed when expanding the object declaration. + 2014-10-10 Robert Dewar * exp_intr.adb (Write_Entity_Name): Moved to outer level diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index f26059adbc3..e540b41a3dd 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -2318,6 +2318,67 @@ package body Errout is end if; end Remove_Warning_Messages; + ---------------------- + -- Adjust_Name_Case -- + ---------------------- + + procedure Adjust_Name_Case (Loc : Source_Ptr) is + begin + -- We have an all lower case name from Namet, and now we want to set + -- the appropriate case. If possible we copy the actual casing from + -- the source. If not we use standard identifier casing. + + declare + Src_Ind : constant Source_File_Index := Get_Source_File_Index (Loc); + Sbuffer : Source_Buffer_Ptr; + Ref_Ptr : Integer; + Src_Ptr : Source_Ptr; + + begin + Ref_Ptr := 1; + Src_Ptr := Loc; + + -- For standard locations, always use mixed case + + if Loc <= No_Location then + Set_Casing (Mixed_Case); + + else + -- Determine if the reference we are dealing with corresponds to + -- text at the point of the error reference. This will often be + -- the case for simple identifier references, and is the case + -- where we can copy the casing from the source. + + Sbuffer := Source_Text (Src_Ind); + + while Ref_Ptr <= Name_Len loop + exit when + Fold_Lower (Sbuffer (Src_Ptr)) /= + Fold_Lower (Name_Buffer (Ref_Ptr)); + Ref_Ptr := Ref_Ptr + 1; + Src_Ptr := Src_Ptr + 1; + end loop; + + -- If we get through the loop without a mismatch, then output the + -- name the way it is cased in the source program + + if Ref_Ptr > Name_Len then + Src_Ptr := Loc; + + for J in 1 .. Name_Len loop + Name_Buffer (J) := Sbuffer (Src_Ptr); + Src_Ptr := Src_Ptr + 1; + end loop; + + -- Otherwise set the casing using the default identifier casing + + else + Set_Casing (Identifier_Casing (Src_Ind), Mixed_Case); + end if; + end if; + end; + end Adjust_Name_Case; + --------------------------- -- Set_Identifier_Casing -- --------------------------- @@ -2660,6 +2721,7 @@ package body Errout is ------------------ procedure Set_Msg_Node (Node : Node_Id) is + Loc : Source_Ptr; Ent : Entity_Id; Nam : Name_Id; @@ -2692,6 +2754,7 @@ package body Errout is if Nkind (Node) = N_Pragma then Nam := Pragma_Name (Node); + Loc := Sloc (Node); -- The other cases have Chars fields, and we want to test for possible -- internal names, which generally represent something gone wrong. An @@ -2712,6 +2775,8 @@ package body Errout is Ent := Node; end if; + Loc := Sloc (Ent); + -- If the type is the designated type of an access_to_subprogram, -- then there is no name to provide in the call. @@ -2729,6 +2794,7 @@ package body Errout is else Nam := Chars (Node); + Loc := Sloc (Node); end if; -- At this stage, the name to output is in Nam @@ -2736,7 +2802,7 @@ package body Errout is Get_Unqualified_Decoded_Name_String (Nam); -- Remove trailing upper case letters from the name (useful for - -- dealing with some cases of internal names. + -- dealing with some cases of internal names). while Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' loop Name_Len := Name_Len - 1; @@ -2752,63 +2818,9 @@ package body Errout is Kill_Message := True; end if; - -- Now we have to set the proper case. If we have a source location - -- then do a check to see if the name in the source is the same name - -- as the name in the Names table, except for possible differences - -- in case, which is the case when we can copy from the source. - - declare - Src_Loc : constant Source_Ptr := Sloc (Node); - Sbuffer : Source_Buffer_Ptr; - Ref_Ptr : Integer; - Src_Ptr : Source_Ptr; - - begin - Ref_Ptr := 1; - Src_Ptr := Src_Loc; - - -- For standard locations, always use mixed case - - if Src_Loc <= No_Location - or else Sloc (Node) <= No_Location - then - Set_Casing (Mixed_Case); - - else - -- Determine if the reference we are dealing with corresponds to - -- text at the point of the error reference. This will often be - -- the case for simple identifier references, and is the case - -- where we can copy the spelling from the source. - - Sbuffer := Source_Text (Get_Source_File_Index (Src_Loc)); - - while Ref_Ptr <= Name_Len loop - exit when - Fold_Lower (Sbuffer (Src_Ptr)) /= - Fold_Lower (Name_Buffer (Ref_Ptr)); - Ref_Ptr := Ref_Ptr + 1; - Src_Ptr := Src_Ptr + 1; - end loop; - - -- If we get through the loop without a mismatch, then output the - -- name the way it is spelled in the source program - - if Ref_Ptr > Name_Len then - Src_Ptr := Src_Loc; - - for J in 1 .. Name_Len loop - Name_Buffer (J) := Sbuffer (Src_Ptr); - Src_Ptr := Src_Ptr + 1; - end loop; - - -- Otherwise set the casing using the default identifier casing - - else - Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case); - end if; - end if; - end; + -- Remaining step is to adjust casing and possibly add 'Class + Adjust_Name_Case (Loc); Set_Msg_Name_Buffer; Add_Class; end Set_Msg_Node; diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index abde9b435ac..ef4a9cf682b 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -879,17 +879,23 @@ package Errout is -- Same as Error_Msg_NE, but the error is suppressed if SPARK_Mode is Off. -- The routine is inlined because it acts as a simple wrapper. - ------------------------------------ - -- Utility Interface for Back End -- - ------------------------------------ + ------------------------------------------ + -- Utility Interface for Casing Control -- + ------------------------------------------ - -- The following subprograms can be used by the back end for the purposes - -- of concocting error messages that are not output via Errout, e.g. the - -- messages generated by the gcc back end. + procedure Adjust_Name_Case (Loc : Source_Ptr); + -- Given a name stored in Name_Buffer (1 .. Name_Len), set proper casing. + -- Loc is an associated source position, if we can find a match between + -- the name in Name_Buffer and the name at that source location, we copy + -- the casing from the source, otherwise we set appropriate default casing. procedure Set_Identifier_Casing (Identifier_Name : System.Address; File_Name : System.Address); + -- This subprogram can be used by the back end for the purposes of + -- concocting error messages that are not output via Errout, e.g. + -- the messages generated by the gcc back end. + -- -- The identifier is a null terminated string that represents the name of -- an identifier appearing in the source program. File_Name is a null -- terminated string giving the corresponding file name for the identifier diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index aa73839d887..e8efe03348c 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -27,6 +27,7 @@ with Atree; use Atree; with Checks; use Checks; with Einfo; use Einfo; with Elists; use Elists; +with Errout; use Errout; with Expander; use Expander; with Exp_Atag; use Exp_Atag; with Exp_Ch4; use Exp_Ch4; @@ -156,8 +157,7 @@ package body Exp_Intr is Ent := Current_Scope; while Present (Ent) loop - exit when Ekind (Ent) /= E_Block - and then Ekind (Ent) /= E_Loop; + exit when not Ekind_In (Ent, E_Block, E_Loop); Ent := Scope (Ent); end loop; @@ -203,6 +203,7 @@ package body Exp_Intr is Name_Buffer (Save_NL + 1 .. Save_NL + Name_Len) := Name_Buffer (1 .. Name_Len); Name_Buffer (1 .. Save_NL) := Save_NB; + Name_Len := Name_Len + Save_NL; end Add_Source_Info; --------------------------------- @@ -1401,65 +1402,104 @@ package body Exp_Intr is ----------------------- procedure Write_Entity_Name (E : Entity_Id) is - SDef : Source_Ptr; - TDef : constant Source_Buffer_Ptr := - Source_Text (Get_Source_File_Index (Sloc (E))); - begin - -- Nothing to do if at outer level + procedure Write_Entity_Name_Inner (E : Entity_Id); + -- Inner recursive routine, keep outer routine non-recursive to ease + -- debugging when we get strange results from this routine. - if Scope (E) = Standard_Standard then - null; + ----------------------------- + -- Write_Entity_Name_Inner -- + ----------------------------- + + procedure Write_Entity_Name_Inner (E : Entity_Id) is + begin + -- If entity has an internal name, skip by it, and print its scope. + -- Note that Is_Internal_Name destroys Name_Buffer, hence the save + -- and restore since we depend on its current contents. Note that + -- we strip a final R from the name before the test, this is needed + -- for some cases of instantiations. + + declare + Save_NB : constant String := Name_Buffer (1 .. Name_Len); + Save_NL : constant Natural := Name_Len; + Iname : Boolean; + + begin + Get_Name_String (Chars (E)); + + if Name_Buffer (Name_Len) = 'R' then + Name_Len := Name_Len - 1; + end if; + + Iname := Is_Internal_Name; + + Name_Buffer (1 .. Save_NL) := Save_NB; + Name_Len := Save_NL; + + if Iname then + Write_Entity_Name_Inner (Scope (E)); + return; + end if; + end; - -- If scope comes from source, write its name + -- Just print entity name if its scope is at the outer level + + if Scope (E) = Standard_Standard then + null; - elsif Comes_From_Source (Scope (E)) then - Write_Entity_Name (Scope (E)); - Add_Char_To_Name_Buffer ('.'); + -- If scope comes from source, write scope and entity + + elsif Comes_From_Source (Scope (E)) then + Write_Entity_Name (Scope (E)); + Add_Char_To_Name_Buffer ('.'); -- If in wrapper package skip past it - elsif Is_Wrapper_Package (Scope (E)) then - Write_Entity_Name (Scope (Scope (E))); - Add_Char_To_Name_Buffer ('.'); + elsif Is_Wrapper_Package (Scope (E)) then + Write_Entity_Name (Scope (Scope (E))); + Add_Char_To_Name_Buffer ('.'); -- Otherwise nothing to output (happens in unnamed block statements) - else - null; - end if; + else + null; + end if; - -- Output the name + -- Output the name - SDef := Sloc (E); + declare + Save_NB : constant String := Name_Buffer (1 .. Name_Len); + Save_NL : constant Natural := Name_Len; - -- Check for operator name in quotes + begin + Get_Unqualified_Decoded_Name_String (Chars (E)); - if TDef (SDef) = '"' then - Add_Char_To_Name_Buffer ('"'); + -- Remove trailing upper case letters from the name (useful for + -- dealing with some cases of internal names generated in the case + -- of references from within a generic. - -- Loop to output characters of operator name and terminating quote + while Name_Len > 1 + and then Name_Buffer (Name_Len) in 'A' .. 'Z' + loop + Name_Len := Name_Len - 1; + end loop; - loop - SDef := SDef + 1; - Add_Char_To_Name_Buffer (TDef (SDef)); - exit when TDef (SDef) = '"'; - end loop; + -- Adjust casing appropriately (gets name from source if possible) - -- Normal case of identifier + Adjust_Name_Case (Sloc (E)); - else - -- Loop to output the name + -- Append to original entry value of Name_Buffer - -- This is not right wrt wide char encodings ??? () + Name_Buffer (Save_NL + 1 .. Save_NL + Name_Len) := + Name_Buffer (1 .. Name_Len); + Name_Buffer (1 .. Save_NL) := Save_NB; + Name_Len := Save_NL + Name_Len; + end; + end Write_Entity_Name_Inner; - while TDef (SDef) in '0' .. '9' - or else TDef (SDef) >= 'A' - or else TDef (SDef) = ASCII.ESC - loop - Add_Char_To_Name_Buffer (TDef (SDef)); - SDef := SDef + 1; - end loop; - end if; + -- Start of processing for Write_Entity_Name + + begin + Write_Entity_Name_Inner (E); end Write_Entity_Name; end Exp_Intr; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index d5dbb440fbb..7fdd2ab5289 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -4415,6 +4415,23 @@ package body Freeze is and then Ekind (E) /= E_Generic_Function then Freeze_And_Append (Etype (E), N, Result); + + -- For an object of an anonymous array type, aspects on the + -- object declaration apply to the type itself. This is the + -- case for Atomic_Components, Volatile_Components, and + -- Independent_Components. In these cases analysis of the + -- generated pragma will mark the anonymous types accordingly, + -- and the object itself does not require a freeze node. + + if Ekind (E) = E_Variable + and then Is_Itype (Etype (E)) + and then Is_Array_Type (Etype (E)) + and then Has_Delayed_Aspects (E) + then + Set_Has_Delayed_Aspects (E, False); + Set_Has_Delayed_Freeze (E, False); + Set_Freeze_Node (E, Empty); + end if; end if; -- Special processing for objects created by object declaration diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 3448e515189..d1df888579c 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3407,11 +3407,21 @@ package body Sem_Ch3 is end if; end if; - -- If not a deferred constant, then object declaration freezes its type + -- If not a deferred constant, then the object declaration freezes + -- its type, unless the object is of an anonymous type and has delayed + -- aspects. In that case the type is frozen when the object itself is. else Check_Fully_Declared (T, N); - Freeze_Before (N, T); + + if Has_Delayed_Aspects (Id) + and then Is_Array_Type (T) + and then Is_Itype (T) + then + Set_Has_Delayed_Freeze (T); + else + Freeze_Before (N, T); + end if; end if; -- If the object was created by a constrained array definition, then diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index bde78e41776..62d9a03e441 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -24755,7 +24755,7 @@ package body Sem_Prag is -- 0 indicates that appearance in any argument is not significant -- +n indicates that appearance as argument n is significant, but all -- other arguments are not significant - -- 99 special processing required (e.g. for pragma Check) + -- 9n arguments from n on are significant, before n inisignificant Sig_Flags : constant array (Pragma_Id) of Int := (Pragma_Abort_Defer => -1, @@ -24767,8 +24767,8 @@ package body Sem_Prag is Pragma_Ada_12 => -1, Pragma_Ada_2012 => -1, Pragma_All_Calls_Remote => -1, - Pragma_Allow_Integer_Address => 0, - Pragma_Annotate => -1, + Pragma_Allow_Integer_Address => -1, + Pragma_Annotate => 93, Pragma_Assert => -1, Pragma_Assert_And_Cut => -1, Pragma_Assertion_Policy => 0, @@ -24776,53 +24776,53 @@ package body Sem_Prag is Pragma_Assume_No_Invalid_Values => 0, Pragma_Async_Readers => 0, Pragma_Async_Writers => 0, - Pragma_Asynchronous => -1, + Pragma_Asynchronous => 0, Pragma_Atomic => 0, Pragma_Atomic_Components => 0, Pragma_Attach_Handler => -1, - Pragma_Attribute_Definition => +3, - Pragma_Check => 99, + Pragma_Attribute_Definition => 92, + Pragma_Check => -1, Pragma_Check_Float_Overflow => 0, Pragma_Check_Name => 0, Pragma_Check_Policy => 0, - Pragma_CIL_Constructor => -1, + Pragma_CIL_Constructor => 0, Pragma_CPP_Class => 0, Pragma_CPP_Constructor => 0, Pragma_CPP_Virtual => 0, Pragma_CPP_Vtable => 0, Pragma_CPU => -1, Pragma_C_Pass_By_Copy => 0, - Pragma_Comment => 0, - Pragma_Common_Object => -1, + Pragma_Comment => -1, + Pragma_Common_Object => 0, Pragma_Compile_Time_Error => -1, Pragma_Compile_Time_Warning => -1, - Pragma_Compiler_Unit => 0, - Pragma_Compiler_Unit_Warning => 0, + Pragma_Compiler_Unit => -1, + Pragma_Compiler_Unit_Warning => -1, Pragma_Complete_Representation => 0, Pragma_Complex_Representation => 0, - Pragma_Component_Alignment => -1, + Pragma_Component_Alignment => 0, Pragma_Contract_Cases => -1, Pragma_Controlled => 0, Pragma_Convention => 0, Pragma_Convention_Identifier => 0, Pragma_Debug => -1, Pragma_Debug_Policy => 0, - Pragma_Detect_Blocking => -1, + Pragma_Detect_Blocking => 0, Pragma_Default_Initial_Condition => -1, Pragma_Default_Scalar_Storage_Order => 0, - Pragma_Default_Storage_Pool => -1, + Pragma_Default_Storage_Pool => 0, Pragma_Depends => -1, - Pragma_Disable_Atomic_Synchronization => -1, + Pragma_Disable_Atomic_Synchronization => 0, Pragma_Discard_Names => 0, Pragma_Dispatching_Domain => -1, Pragma_Effective_Reads => 0, Pragma_Effective_Writes => 0, - Pragma_Elaborate => -1, - Pragma_Elaborate_All => -1, - Pragma_Elaborate_Body => -1, - Pragma_Elaboration_Checks => -1, - Pragma_Eliminate => -1, - Pragma_Enable_Atomic_Synchronization => -1, + Pragma_Elaborate => 0, + Pragma_Elaborate_All => 0, + Pragma_Elaborate_Body => 0, + Pragma_Elaboration_Checks => 0, + Pragma_Eliminate => 0, + Pragma_Enable_Atomic_Synchronization => 0, Pragma_Export => -1, Pragma_Export_Function => -1, Pragma_Export_Object => -1, @@ -24830,18 +24830,18 @@ package body Sem_Prag is Pragma_Export_Value => -1, Pragma_Export_Valued_Procedure => -1, Pragma_Extend_System => -1, - Pragma_Extensions_Allowed => -1, + Pragma_Extensions_Allowed => 0, Pragma_External => -1, - Pragma_Favor_Top_Level => -1, - Pragma_External_Name_Casing => -1, - Pragma_Fast_Math => -1, + Pragma_Favor_Top_Level => 0, + Pragma_External_Name_Casing => 0, + Pragma_Fast_Math => 0, Pragma_Finalize_Storage_Only => 0, Pragma_Global => -1, Pragma_Ident => -1, Pragma_Implementation_Defined => -1, Pragma_Implemented => -1, Pragma_Implicit_Packing => 0, - Pragma_Import => +2, + Pragma_Import => 93, Pragma_Import_Function => 0, Pragma_Import_Object => 0, Pragma_Import_Procedure => 0, @@ -24849,14 +24849,14 @@ package body Sem_Prag is Pragma_Independent => 0, Pragma_Independent_Components => 0, Pragma_Initial_Condition => -1, - Pragma_Initialize_Scalars => -1, + Pragma_Initialize_Scalars => 0, Pragma_Initializes => -1, Pragma_Inline => 0, Pragma_Inline_Always => 0, Pragma_Inline_Generic => 0, Pragma_Inspection_Point => -1, - Pragma_Interface => +2, - Pragma_Interface_Name => +2, + Pragma_Interface => 92, + Pragma_Interface_Name => 0, Pragma_Interrupt_Handler => -1, Pragma_Interrupt_Priority => -1, Pragma_Interrupt_State => -1, @@ -24864,41 +24864,41 @@ package body Sem_Prag is Pragma_Java_Constructor => -1, Pragma_Java_Interface => -1, Pragma_Keep_Names => 0, - Pragma_License => -1, + Pragma_License => 0, Pragma_Link_With => -1, Pragma_Linker_Alias => -1, Pragma_Linker_Constructor => -1, Pragma_Linker_Destructor => -1, Pragma_Linker_Options => -1, - Pragma_Linker_Section => -1, - Pragma_List => -1, - Pragma_Lock_Free => -1, - Pragma_Locking_Policy => -1, + Pragma_Linker_Section => 0, + Pragma_List => 0, + Pragma_Lock_Free => 0, + Pragma_Locking_Policy => 0, Pragma_Loop_Invariant => -1, - Pragma_Loop_Optimize => -1, + Pragma_Loop_Optimize => 0, Pragma_Loop_Variant => -1, Pragma_Machine_Attribute => -1, Pragma_Main => -1, Pragma_Main_Storage => -1, - Pragma_Memory_Size => -1, + Pragma_Memory_Size => 0, Pragma_No_Return => 0, Pragma_No_Body => 0, - Pragma_No_Elaboration_Code_All => -1, + Pragma_No_Elaboration_Code_All => 0, Pragma_No_Inline => 0, Pragma_No_Run_Time => -1, Pragma_No_Strict_Aliasing => -1, - Pragma_Normalize_Scalars => -1, + Pragma_Normalize_Scalars => 0, Pragma_Obsolescent => 0, - Pragma_Optimize => -1, - Pragma_Optimize_Alignment => -1, + Pragma_Optimize => 0, + Pragma_Optimize_Alignment => 0, Pragma_Overflow_Mode => 0, Pragma_Overriding_Renamings => 0, - Pragma_Ordered => -1, + Pragma_Ordered => 0, Pragma_Pack => 0, - Pragma_Page => -1, - Pragma_Part_Of => -1, - Pragma_Partition_Elaboration_Policy => -1, - Pragma_Passive => -1, + Pragma_Page => 0, + Pragma_Part_Of => 0, + Pragma_Partition_Elaboration_Policy => 0, + Pragma_Passive => 0, Pragma_Persistent_BSS => 0, Pragma_Polling => 0, Pragma_Prefix_Exception_Messages => 0, @@ -24909,81 +24909,81 @@ package body Sem_Prag is Pragma_Precondition => -1, Pragma_Predicate => -1, Pragma_Preelaborable_Initialization => -1, - Pragma_Preelaborate => -1, + Pragma_Preelaborate => 0, Pragma_Pre_Class => -1, Pragma_Priority => -1, - Pragma_Priority_Specific_Dispatching => -1, + Pragma_Priority_Specific_Dispatching => 0, Pragma_Profile => 0, Pragma_Profile_Warnings => 0, - Pragma_Propagate_Exceptions => -1, - Pragma_Provide_Shift_Operators => -1, - Pragma_Psect_Object => -1, - Pragma_Pure => -1, - Pragma_Pure_Function => -1, - Pragma_Queuing_Policy => -1, - Pragma_Rational => -1, - Pragma_Ravenscar => -1, + Pragma_Propagate_Exceptions => 0, + Pragma_Provide_Shift_Operators => 0, + Pragma_Psect_Object => 0, + Pragma_Pure => 0, + Pragma_Pure_Function => 0, + Pragma_Queuing_Policy => 0, + Pragma_Rational => 0, + Pragma_Ravenscar => 0, Pragma_Refined_Depends => -1, Pragma_Refined_Global => -1, Pragma_Refined_Post => -1, Pragma_Refined_State => -1, - Pragma_Relative_Deadline => -1, + Pragma_Relative_Deadline => 0, Pragma_Remote_Access_Type => -1, Pragma_Remote_Call_Interface => -1, Pragma_Remote_Types => -1, - Pragma_Restricted_Run_Time => -1, - Pragma_Restriction_Warnings => -1, - Pragma_Restrictions => -1, + Pragma_Restricted_Run_Time => 0, + Pragma_Restriction_Warnings => 0, + Pragma_Restrictions => 0, Pragma_Reviewable => -1, - Pragma_Short_Circuit_And_Or => -1, - Pragma_Share_Generic => -1, - Pragma_Shared => -1, - Pragma_Shared_Passive => -1, + Pragma_Short_Circuit_And_Or => 0, + Pragma_Share_Generic => 0, + Pragma_Shared => 0, + Pragma_Shared_Passive => 0, Pragma_Short_Descriptors => 0, Pragma_Simple_Storage_Pool_Type => 0, - Pragma_Source_File_Name => -1, - Pragma_Source_File_Name_Project => -1, - Pragma_Source_Reference => -1, + Pragma_Source_File_Name => 0, + Pragma_Source_File_Name_Project => 0, + Pragma_Source_Reference => 0, Pragma_SPARK_Mode => 0, Pragma_Storage_Size => -1, - Pragma_Storage_Unit => -1, - Pragma_Static_Elaboration_Desired => -1, - Pragma_Stream_Convert => -1, - Pragma_Style_Checks => -1, - Pragma_Subtitle => -1, + Pragma_Storage_Unit => 0, + Pragma_Static_Elaboration_Desired => 0, + Pragma_Stream_Convert => 0, + Pragma_Style_Checks => 0, + Pragma_Subtitle => 0, Pragma_Suppress => 0, Pragma_Suppress_Exception_Locations => 0, - Pragma_Suppress_All => -1, + Pragma_Suppress_All => 0, Pragma_Suppress_Debug_Info => 0, Pragma_Suppress_Initialization => 0, - Pragma_System_Name => -1, - Pragma_Task_Dispatching_Policy => -1, + Pragma_System_Name => 0, + Pragma_Task_Dispatching_Policy => 0, Pragma_Task_Info => -1, Pragma_Task_Name => -1, - Pragma_Task_Storage => 0, + Pragma_Task_Storage => -1, Pragma_Test_Case => -1, - Pragma_Thread_Local_Storage => 0, + Pragma_Thread_Local_Storage => -1, Pragma_Time_Slice => -1, - Pragma_Title => -1, + Pragma_Title => 0, Pragma_Type_Invariant => -1, Pragma_Type_Invariant_Class => -1, Pragma_Unchecked_Union => 0, - Pragma_Unimplemented_Unit => -1, - Pragma_Universal_Aliasing => -1, - Pragma_Universal_Data => -1, - Pragma_Unmodified => -1, - Pragma_Unreferenced => -1, - Pragma_Unreferenced_Objects => -1, - Pragma_Unreserve_All_Interrupts => -1, + Pragma_Unimplemented_Unit => 0, + Pragma_Universal_Aliasing => 0, + Pragma_Universal_Data => 0, + Pragma_Unmodified => 0, + Pragma_Unreferenced => 0, + Pragma_Unreferenced_Objects => 0, + Pragma_Unreserve_All_Interrupts => 0, Pragma_Unsuppress => 0, Pragma_Unevaluated_Use_Of_Old => 0, - Pragma_Use_VADS_Size => -1, - Pragma_Validity_Checks => -1, + Pragma_Use_VADS_Size => 0, + Pragma_Validity_Checks => 0, Pragma_Volatile => 0, Pragma_Volatile_Components => 0, - Pragma_Warning_As_Error => -1, - Pragma_Warnings => -1, - Pragma_Weak_External => -1, + Pragma_Warning_As_Error => 0, + Pragma_Warnings => 0, + Pragma_Weak_External => 0, Pragma_Wide_Character_Encoding => 0, Unknown_Pragma => 0); @@ -24991,7 +24991,36 @@ package body Sem_Prag is Id : Pragma_Id; P : Node_Id; C : Int; - A : Node_Id; + AN : Nat; + + function Arg_No return Nat; + -- Returns an integer showing what argument we are in. A value of + -- zero means we are not in any of the arguments. + + ------------ + -- Arg_No -- + ------------ + + function Arg_No return Nat is + A : Node_Id; + N : Nat; + + begin + A := First (Pragma_Argument_Associations (Parent (P))); + N := 1; + loop + if No (A) then + return 0; + elsif A = P then + return N; + end if; + + Next (A); + N := N + 1; + end loop; + end Arg_No; + + -- Start of processing for Non_Significant_Pragma_Reference begin P := Parent (N); @@ -25002,6 +25031,11 @@ package body Sem_Prag is else Id := Get_Pragma_Id (Parent (P)); C := Sig_Flags (Id); + AN := Arg_No; + + if AN = 0 then + return False; + end if; case C is when -1 => @@ -25010,32 +25044,11 @@ package body Sem_Prag is when 0 => return True; - when 99 => - case Id is - - -- For pragma Check, the first argument is not significant, - -- the second and the third (if present) arguments are - -- significant. - - when Pragma_Check => - return - P = First (Pragma_Argument_Associations (Parent (P))); - - when others => - raise Program_Error; - end case; + when 92 .. 99 => + return AN < (C - 90); when others => - A := First (Pragma_Argument_Associations (Parent (P))); - for J in 1 .. C - 1 loop - if No (A) then - return False; - end if; - - Next (A); - end loop; - - return A = P; -- is this wrong way round ??? + return AN /= C; end case; end if; end Is_Non_Significant_Pragma_Reference; diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 3eb4869f8f8..8f47053a299 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -3000,6 +3000,12 @@ package body Sprint is when N_Raise_Statement => Write_Indent_Str_Sloc ("raise "); Sprint_Node (Name (Node)); + + if Present (Expression (Node)) then + Write_Str_With_Col_Check_Sloc (" with "); + Sprint_Node (Expression (Node)); + end if; + Write_Char (';'); when N_Range => -- 2.30.2