Skip to content

R
riscv-gcc-1
Commit 14c34330 by Arnaud Charlet
Options

[multiple changes] 

2013-09-10  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb: sem_ch3.adb:
	(Replace_Anonymoous_Access_To_Protected_Subprogram): If the
	return type is itself an access to function, recurse to emit
	another anonymous type.
	gcc-interface/decl.c (gnat_to_gnu_entity): In ASIS mode
	(type_annotate_only) do not check whether access types have a set size.

2013-09-10  Robert Dewar  <dewar@adacore.com>

	* err_vars.ads (Warning_Doc_Switch): Ignored in VMS mode.
	* errout.adb (Warning_Doc_Switch): Ignored in VMS mode.
	* errout.ads (Warning_Doc_Switch): Ignored in VMS mode.
	* inline.ads (Warnings): New component in Pending_Body_Info.
	* sem_ch12.adb (Pending_Body_Info): Save and restore warnings
	at instantiation point.
	* warnsw.adb (Save_Warnings): New function (Restore_Warnings):
	New procedure Remove special handling of Warning_Doc_Switch,
	cleaner to handle the VMS case in errout, than to introduce
	undocumented oddities here.
	* warnsw.ads (Warning_Record) : New type.
	(Save_Warnings): New function.
	(Restore_Warnings): New procedure.

From-SVN: r202467
parent fb620b37
Showing with 334 additions and 34 deletions
gcc/ada/ChangeLog
2013-09-10 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb (Replace_Anonymoous_Access_To_Protected_Subprogram): If
the return type is itself an access to function, recurse to emit
another anonymous type.
* gcc-interface/Make-lang.in: Update dependencies.
2013-09-10 Robert Dewar <dewar@adacore.com>
* err_vars.ads (Warning_Doc_Switch): Ignored in VMS mode.
* errout.adb (Warning_Doc_Switch): Ignored in VMS mode.
* errout.ads (Warning_Doc_Switch): Ignored in VMS mode.
* inline.ads (Warnings): New component in Pending_Body_Info.
* sem_ch12.adb (Pending_Body_Info): Save and restore warnings
at instantiation point.
* warnsw.adb (Save_Warnings): New function (Restore_Warnings):
New procedure Remove special handling of Warning_Doc_Switch,
cleaner to handle the VMS case in errout, than to introduce
undocumented oddities here.
* warnsw.ads (Warning_Record) : New type.
(Save_Warnings): New function.
(Restore_Warnings): New procedure.
2013-09-10 Robert Dewar <dewar@adacore.com>
* sinput.adb (Check_For_BOM): Avoid reading past end of file.
......
gcc/ada/err_vars.ads
......@@ -93,6 +93,7 @@ package Err_Vars is
-- are active (see errout.ads for details). If this switch is False, then
-- these sequences are ignored (i.e. simply equivalent to a single ?). The
-- -gnatw.d switch sets this flag True, -gnatw.D sets this flag False.
-- Note: always ignored on VMS, where we do not provide this capability.
----------------------------------------
-- Error Message Insertion Parameters --
......
gcc/ada/errout.adb
......@@ -49,6 +49,7 @@ with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Stylesw; use Stylesw;
with Targparm; use Targparm;
with Uname; use Uname;
package body Errout is
......@@ -2704,7 +2705,7 @@ package body Errout is
Warning_Msg_Char := ' ';
if P <= Text'Last and then Text (P) = '?' then
if Warning_Doc_Switch then
if Warning_Doc_Switch and not OpenVMS_On_Target then
Warning_Msg_Char := '?';
end if;
......@@ -2716,7 +2717,7 @@ package body Errout is
Text (P) in 'A' .. 'Z')
and then Text (P + 1) = '?'
then
if Warning_Doc_Switch then
if Warning_Doc_Switch and not OpenVMS_On_Target then
Warning_Msg_Char := Text (P);
end if;
......@@ -2802,7 +2803,10 @@ package body Errout is
-- If tagging of messages is enabled, and this is a warning,
-- then it is treated as being [enabled by default].
if Error_Msg_Warn and Warning_Doc_Switch then
if Error_Msg_Warn
and Warning_Doc_Switch
and not OpenVMS_On_Target
then
Warning_Msg_Char := '?';
end if;
......
gcc/ada/errout.ads
......@@ -64,6 +64,7 @@ package Errout is
-- are active (see errout.ads for details). If this switch is False, then
-- these sequences are ignored (i.e. simply equivalent to a single ?). The
-- -gnatw.d switch sets this flag True, -gnatw.D sets this flag False.
-- Note: always ignored in VMS mode where we do not provide this feature.
-----------------------------------
-- Suppression of Error Messages --
......@@ -695,7 +696,9 @@ package Errout is
procedure Error_Msg_F (Msg : String; N : Node_Id);
-- Similar to Error_Msg_N except that the message is placed on the first
-- node of the construct N (First_Node (N)).
-- node of the construct N (First_Node (N)). Note that this procedure uses
-- Original_Node to look at the original source tree, since that's what we
-- want for placing an error message flag in the right place.
procedure Error_Msg_NE
(Msg : String;
......@@ -739,8 +742,11 @@ package Errout is
-- usual manner, and need not be the same length as the original text.
function First_Node (C : Node_Id) return Node_Id;
-- Given a construct C, finds the first node in the construct, i.e. the
-- one with the lowest Sloc value. This is useful in placing error msgs.
-- Given a construct C, finds the first node in the construct, i.e. the one
-- with the lowest Sloc value. This is useful in placing error msgs. Note
-- that this procedure uses Original_Node to look at the original source
-- tree, since that's what we want for placing an error message flag in
-- the right place.
function First_Sloc (N : Node_Id) return Source_Ptr;
-- Given the node for an expression, return a source pointer value that
......
gcc/ada/inline.ads
......@@ -40,6 +40,7 @@ with Opt; use Opt;
with Sem; use Sem;
with Table;
with Types; use Types;
with Warnsw; use Warnsw;
package Inline is
......@@ -92,6 +93,9 @@ package Inline is
Version_Pragma : Node_Id;
-- This is linked with the Version value
Warnings : Warning_Record;
-- Capture values of warning flags
end record;
package Pending_Instantiations is new Table.Table (
......
gcc/ada/sem_ch12.adb
......@@ -76,6 +76,7 @@ with Table;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Urealp; use Urealp;
with Warnsw; use Warnsw;
with GNAT.HTable;
......@@ -3895,7 +3896,8 @@ package body Sem_Ch12 is
Scope_Suppress => Scope_Suppress,
Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
Version => Ada_Version,
Version_Pragma => Ada_Version_Pragma));
Version_Pragma => Ada_Version_Pragma,
Warnings => Save_Warnings));
end if;
end if;
......@@ -4240,7 +4242,8 @@ package body Sem_Ch12 is
Scope_Suppress => Scope_Suppress,
Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
Version => Ada_Version,
Version_Pragma => Ada_Version_Pragma)),
Version_Pragma => Ada_Version_Pragma,
Warnings => Save_Warnings)),
Inlined_Body => True);
Pop_Scope;
......@@ -4357,7 +4360,8 @@ package body Sem_Ch12 is
Scope_Suppress => Scope_Suppress,
Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
Version => Ada_Version,
Version_Pragma => Ada_Version_Pragma)),
Version_Pragma => Ada_Version_Pragma,
Warnings => Save_Warnings)),
Inlined_Body => True);
end if;
end Inline_Instance_Body;
......@@ -4414,7 +4418,8 @@ package body Sem_Ch12 is
Scope_Suppress => Scope_Suppress,
Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
Version => Ada_Version,
Version_Pragma => Ada_Version_Pragma));
Version_Pragma => Ada_Version_Pragma,
Warnings => Save_Warnings));
return True;
-- Here if not inlined, or we ignore the inlining
......@@ -9914,6 +9919,7 @@ package body Sem_Ch12 is
Scope_Suppress := Body_Info.Scope_Suppress;
Opt.Ada_Version := Body_Info.Version;
Opt.Ada_Version_Pragma := Body_Info.Version_Pragma;
Restore_Warnings (Body_Info.Warnings);
if No (Gen_Body_Id) then
Load_Parent_Of_Generic
......@@ -10174,7 +10180,9 @@ package body Sem_Ch12 is
Unit_Renaming : Node_Id;
Parent_Installed : Boolean := False;
Save_Style_Check : constant Boolean := Style_Check;
Saved_Style_Check : constant Boolean := Style_Check;
Saved_Warnings : constant Warning_Record := Save_Warnings;
Par_Ent : Entity_Id := Empty;
Par_Vis : Boolean := False;
......@@ -10201,6 +10209,7 @@ package body Sem_Ch12 is
Scope_Suppress := Body_Info.Scope_Suppress;
Opt.Ada_Version := Body_Info.Version;
Opt.Ada_Version_Pragma := Body_Info.Version_Pragma;
Restore_Warnings (Body_Info.Warnings);
if No (Gen_Body_Id) then
......@@ -10380,7 +10389,8 @@ package body Sem_Ch12 is
end if;
Restore_Env;
Style_Check := Save_Style_Check;
Style_Check := Saved_Style_Check;
Restore_Warnings (Saved_Warnings);
-- Body not found. Error was emitted already. If there were no previous
-- errors, this may be an instance whose scope is a premature instance.
......@@ -11861,7 +11871,8 @@ package body Sem_Ch12 is
Body_Optional : Boolean := False)
is
Comp_Unit : constant Node_Id := Cunit (Get_Source_Unit (Spec));
Save_Style_Check : constant Boolean := Style_Check;
Saved_Style_Check : constant Boolean := Style_Check;
Saved_Warnings : constant Warning_Record := Save_Warnings;
True_Parent : Node_Id;
Inst_Node : Node_Id;
OK : Boolean;
......@@ -12096,7 +12107,8 @@ package body Sem_Ch12 is
Local_Suppress_Stack_Top =>
Local_Suppress_Stack_Top,
Version => Ada_Version,
Version_Pragma => Ada_Version_Pragma);
Version_Pragma => Ada_Version_Pragma,
Warnings => Save_Warnings);
-- Package instance
......@@ -12137,7 +12149,8 @@ package body Sem_Ch12 is
Scope_Suppress => Scope_Suppress,
Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
Version => Ada_Version,
Version_Pragma => Ada_Version_Pragma)),
Version_Pragma => Ada_Version_Pragma,
Warnings => Save_Warnings)),
Body_Optional => Body_Optional);
end;
end if;
......@@ -12148,7 +12161,8 @@ package body Sem_Ch12 is
Opt.Style_Check := False;
Expander_Mode_Save_And_Set (True);
Load_Needed_Body (Comp_Unit, OK);
Opt.Style_Check := Save_Style_Check;
Opt.Style_Check := Saved_Style_Check;
Restore_Warnings (Saved_Warnings);
Expander_Mode_Restore;
if not OK
......
gcc/ada/sem_ch3.adb
......@@ -5092,11 +5092,25 @@ package body Sem_Ch3 is
Process_Formals (Parameter_Specifications (Spec), Spec);
if Nkind (Spec) = N_Access_Function_Definition then
if Nkind (Result_Definition (Spec)) = N_Access_Definition then
Find_Type (Subtype_Mark (Result_Definition (Spec)));
declare
Def : constant Node_Id := Result_Definition (Spec);
begin
-- The result might itself be an anonymous access type, so
-- have to recurse.
if Nkind (Def) = N_Access_Definition then
if Present (Access_To_Subprogram_Definition (Def)) then
Set_Etype (Def,
Replace_Anonymous_Access_To_Protected_Subprogram
(Spec));
else
Find_Type (Subtype_Mark (Def));
end if;
else
Find_Type (Result_Definition (Spec));
Find_Type (Def);
end if;
end;
end if;
End_Scope;
......
gcc/ada/warnsw.adb
......@@ -25,9 +25,197 @@
with Err_Vars; use Err_Vars;
with Opt; use Opt;
with Targparm; use Targparm;
package body Warnsw is
----------------------
-- Restore_Warnings --
----------------------
procedure Restore_Warnings (W : Warning_Record) is
begin
Address_Clause_Overlay_Warnings :=
W.Address_Clause_Overlay_Warnings;
Check_Unreferenced :=
W.Check_Unreferenced;
Check_Unreferenced_Formals :=
W.Check_Unreferenced_Formals;
Check_Withs :=
W.Check_Withs;
Constant_Condition_Warnings :=
W.Constant_Condition_Warnings;
Elab_Warnings :=
W.Elab_Warnings;
Implementation_Unit_Warnings :=
W.Implementation_Unit_Warnings;
Ineffective_Inline_Warnings :=
W.Ineffective_Inline_Warnings;
List_Inherited_Aspects :=
W.List_Inherited_Aspects;
Warning_Doc_Switch :=
W.Warning_Doc_Switch;
Warn_On_Ada_2005_Compatibility :=
W.Warn_On_Ada_2005_Compatibility;
Warn_On_Ada_2012_Compatibility :=
W.Warn_On_Ada_2012_Compatibility;
Warn_On_All_Unread_Out_Parameters :=
W.Warn_On_All_Unread_Out_Parameters;
Warn_On_Assertion_Failure :=
W.Warn_On_Assertion_Failure;
Warn_On_Assumed_Low_Bound :=
W.Warn_On_Assumed_Low_Bound;
Warn_On_Atomic_Synchronization :=
W.Warn_On_Atomic_Synchronization;
Warn_On_Bad_Fixed_Value :=
W.Warn_On_Bad_Fixed_Value;
Warn_On_Biased_Representation :=
W.Warn_On_Biased_Representation;
Warn_On_Constant :=
W.Warn_On_Constant;
Warn_On_Deleted_Code :=
W.Warn_On_Deleted_Code;
Warn_On_Dereference :=
W.Warn_On_Dereference;
Warn_On_Export_Import :=
W.Warn_On_Export_Import;
Warn_On_Hiding :=
W.Warn_On_Hiding;
Warn_On_Modified_Unread :=
W.Warn_On_Modified_Unread;
Warn_On_No_Value_Assigned :=
W.Warn_On_No_Value_Assigned;
Warn_On_Non_Local_Exception :=
W.Warn_On_Non_Local_Exception;
Warn_On_Object_Renames_Function :=
W.Warn_On_Object_Renames_Function;
Warn_On_Obsolescent_Feature :=
W.Warn_On_Obsolescent_Feature;
Warn_On_Overlap :=
W.Warn_On_Overlap;
Warn_On_Overridden_Size :=
W.Warn_On_Overridden_Size;
Warn_On_Parameter_Order :=
W.Warn_On_Parameter_Order;
Warn_On_Questionable_Missing_Parens :=
W.Warn_On_Questionable_Missing_Parens;
Warn_On_Record_Holes :=
W.Warn_On_Record_Holes;
Warn_On_Redundant_Constructs :=
W.Warn_On_Redundant_Constructs;
Warn_On_Reverse_Bit_Order :=
W.Warn_On_Reverse_Bit_Order;
Warn_On_Standard_Redefinition :=
W.Warn_On_Standard_Redefinition;
Warn_On_Suspicious_Contract :=
W.Warn_On_Suspicious_Contract;
Warn_On_Unchecked_Conversion :=
W.Warn_On_Unchecked_Conversion;
Warn_On_Unordered_Enumeration_Type :=
W.Warn_On_Unordered_Enumeration_Type;
Warn_On_Unrecognized_Pragma :=
W.Warn_On_Unrecognized_Pragma;
Warn_On_Unrepped_Components :=
W.Warn_On_Unrepped_Components;
Warn_On_Warnings_Off :=
W.Warn_On_Warnings_Off;
end Restore_Warnings;
-------------------
-- Save_Warnings --
-------------------
function Save_Warnings return Warning_Record is
W : Warning_Record;
begin
W.Address_Clause_Overlay_Warnings :=
Address_Clause_Overlay_Warnings;
W.Check_Unreferenced :=
Check_Unreferenced;
W.Check_Unreferenced_Formals :=
Check_Unreferenced_Formals;
W.Check_Withs :=
Check_Withs;
W.Constant_Condition_Warnings :=
Constant_Condition_Warnings;
W.Elab_Warnings :=
Elab_Warnings;
W.Implementation_Unit_Warnings :=
Implementation_Unit_Warnings;
W.Ineffective_Inline_Warnings :=
Ineffective_Inline_Warnings;
W.List_Inherited_Aspects :=
List_Inherited_Aspects;
W.Warning_Doc_Switch :=
Warning_Doc_Switch;
W.Warn_On_Ada_2005_Compatibility :=
Warn_On_Ada_2005_Compatibility;
W.Warn_On_Ada_2012_Compatibility :=
Warn_On_Ada_2012_Compatibility;
W.Warn_On_All_Unread_Out_Parameters :=
Warn_On_All_Unread_Out_Parameters;
W.Warn_On_Assertion_Failure :=
Warn_On_Assertion_Failure;
W.Warn_On_Assumed_Low_Bound :=
Warn_On_Assumed_Low_Bound;
W.Warn_On_Atomic_Synchronization :=
Warn_On_Atomic_Synchronization;
W.Warn_On_Bad_Fixed_Value :=
Warn_On_Bad_Fixed_Value;
W.Warn_On_Biased_Representation :=
Warn_On_Biased_Representation;
W.Warn_On_Constant :=
Warn_On_Constant;
W.Warn_On_Deleted_Code :=
Warn_On_Deleted_Code;
W.Warn_On_Dereference :=
Warn_On_Dereference;
W.Warn_On_Export_Import :=
Warn_On_Export_Import;
W.Warn_On_Hiding :=
Warn_On_Hiding;
W.Warn_On_Modified_Unread :=
Warn_On_Modified_Unread;
W.Warn_On_No_Value_Assigned :=
Warn_On_No_Value_Assigned;
W.Warn_On_Non_Local_Exception :=
Warn_On_Non_Local_Exception;
W.Warn_On_Object_Renames_Function :=
Warn_On_Object_Renames_Function;
W.Warn_On_Obsolescent_Feature :=
Warn_On_Obsolescent_Feature;
W.Warn_On_Overlap :=
Warn_On_Overlap;
W.Warn_On_Overridden_Size :=
Warn_On_Overridden_Size;
W.Warn_On_Parameter_Order :=
Warn_On_Parameter_Order;
W.Warn_On_Questionable_Missing_Parens :=
Warn_On_Questionable_Missing_Parens;
W.Warn_On_Record_Holes :=
Warn_On_Record_Holes;
W.Warn_On_Redundant_Constructs :=
Warn_On_Redundant_Constructs;
W.Warn_On_Reverse_Bit_Order :=
Warn_On_Reverse_Bit_Order;
W.Warn_On_Standard_Redefinition :=
Warn_On_Standard_Redefinition;
W.Warn_On_Suspicious_Contract :=
Warn_On_Suspicious_Contract;
W.Warn_On_Unchecked_Conversion :=
Warn_On_Unchecked_Conversion;
W.Warn_On_Unordered_Enumeration_Type :=
Warn_On_Unordered_Enumeration_Type;
W.Warn_On_Unrecognized_Pragma :=
Warn_On_Unrecognized_Pragma;
W.Warn_On_Unrepped_Components :=
Warn_On_Unrepped_Components;
W.Warn_On_Warnings_Off :=
Warn_On_Warnings_Off;
return W;
end Save_Warnings;
----------------------------
-- Set_Dot_Warning_Switch --
----------------------------
......@@ -54,17 +242,9 @@ package body Warnsw is
Warn_On_Unrepped_Components := False;
when 'd' =>
if OpenVMS_On_Target then
return False;
end if;
Warning_Doc_Switch := True;
when 'D' =>
if OpenVMS_On_Target then
return False;
end if;
Warning_Doc_Switch := False;
when 'e' =>
......@@ -77,11 +257,7 @@ package body Warnsw is
Implementation_Unit_Warnings := True;
Ineffective_Inline_Warnings := True;
List_Inherited_Aspects := True;
if not OpenVMS_On_Target then
Warning_Doc_Switch := True;
end if;
Warn_On_Ada_2005_Compatibility := True;
Warn_On_Ada_2012_Compatibility := True;
Warn_On_All_Unread_Out_Parameters := True;
......
gcc/ada/warnsw.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1999-2012, Free Software Foundation, Inc. --
-- Copyright (C) 1999-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -35,7 +35,8 @@ package Warnsw is
-- whether warnings of a given class will be generated or not.
-- Note: most of these flags are still in opt, but the plan is to move them
-- here as time goes by.
-- here as time goes by. And in fact a really nice idea would be to put
-- them all in a Warn_Record so that they would be easy to save/restore.
Warn_On_Record_Holes : Boolean := False;
-- Warn when explicit record component clauses leave uncovered holes (gaps)
......@@ -52,6 +53,63 @@ package Warnsw is
-- Standard. Off by default, modified by use of -gnatw.k/.K, but not
-- affected by -gnatwa.
-----------------------------------
-- Saving and Restoring Warnings --
-----------------------------------
-- Type used to save and restore warnings
type Warning_Record is record
Address_Clause_Overlay_Warnings : Boolean;
Check_Unreferenced : Boolean;
Check_Unreferenced_Formals : Boolean;
Check_Withs : Boolean;
Constant_Condition_Warnings : Boolean;
Elab_Warnings : Boolean;
Implementation_Unit_Warnings : Boolean;
Ineffective_Inline_Warnings : Boolean;
List_Inherited_Aspects : Boolean;
Warning_Doc_Switch : Boolean;
Warn_On_Ada_2005_Compatibility : Boolean;
Warn_On_Ada_2012_Compatibility : Boolean;
Warn_On_All_Unread_Out_Parameters : Boolean;
Warn_On_Assertion_Failure : Boolean;
Warn_On_Assumed_Low_Bound : Boolean;
Warn_On_Atomic_Synchronization : Boolean;
Warn_On_Bad_Fixed_Value : Boolean;
Warn_On_Biased_Representation : Boolean;
Warn_On_Constant : Boolean;
Warn_On_Deleted_Code : Boolean;
Warn_On_Dereference : Boolean;
Warn_On_Export_Import : Boolean;
Warn_On_Hiding : Boolean;
Warn_On_Modified_Unread : Boolean;
Warn_On_No_Value_Assigned : Boolean;
Warn_On_Non_Local_Exception : Boolean;
Warn_On_Object_Renames_Function : Boolean;
Warn_On_Obsolescent_Feature : Boolean;
Warn_On_Overlap : Boolean;
Warn_On_Overridden_Size : Boolean;
Warn_On_Parameter_Order : Boolean;
Warn_On_Questionable_Missing_Parens : Boolean;
Warn_On_Record_Holes : Boolean;
Warn_On_Redundant_Constructs : Boolean;
Warn_On_Reverse_Bit_Order : Boolean;
Warn_On_Standard_Redefinition : Boolean;
Warn_On_Suspicious_Contract : Boolean;
Warn_On_Unchecked_Conversion : Boolean;
Warn_On_Unordered_Enumeration_Type : Boolean;
Warn_On_Unrecognized_Pragma : Boolean;
Warn_On_Unrepped_Components : Boolean;
Warn_On_Warnings_Off : Boolean;
end record;
function Save_Warnings return Warning_Record;
-- Returns current settingh of warnings
procedure Restore_Warnings (W : Warning_Record);
-- Restores current settings of warning flags from W
-----------------
-- Subprograms --
-----------------
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment