procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[multiple changes]

Browse source 
2014-10-10  Robert Dewar  <dewar@adacore.com>

	* 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  <schonberg@adacore.com>

	* 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
This commit is contained in:
Arnaud Charlet 2014-10-10 16:39:14 +02:00
parent 8f8194710d
commit 32a2109603
8 changed files with 350 additions and 221 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

25
gcc/ada/ChangeLog
View file

@ -1,3 +1,28 @@
2014-10-10 Robert Dewar <dewar@adacore.com>
* 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 <schonberg@adacore.com>
* 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 <dewar@adacore.com>
* exp_intr.adb (Write_Entity_Name): Moved to outer level

126
gcc/ada/errout.adb
View file

@ -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;

18
gcc/ada/errout.ads
View file

@ -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

124
gcc/ada/exp_intr.adb
View file

@ -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 --
-----------------------------
-- If scope comes from source, write its name
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.
elsif Comes_From_Source (Scope (E)) then
Write_Entity_Name (Scope (E));
Add_Char_To_Name_Buffer ('.');
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;
-- Just print entity name if its scope is at the outer level
if Scope (E) = Standard_Standard then
null;
-- 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;

17
gcc/ada/freeze.adb
View file

@ -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

14
gcc/ada/sem_ch3.adb
View file

@ -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

241
gcc/ada/sem_prag.adb
View file

@ -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;

6
gcc/ada/sprint.adb
View file

@ -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 =>