OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

sem_util.adb (Contains_Refined_State): Remove.

Browse Source 
gcc/ada/

2017-12-05  Piotr Trojanek  <trojanek@adacore.com>

	* sem_util.adb (Contains_Refined_State): Remove.

2017-12-05  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch13.adb (Analyze_Aspect_Specifications, case Predicate): A
	predicate cannot apply to a formal type.

2017-12-05  Arnaud Charlet  <charlet@adacore.com>

	* exp_unst.ads: Fix typos.

2017-12-05  Jerome Lambourg  <lambourg@adacore.com>

	* libgnarl/s-taprop__qnx.adb: Better detect priority ceiling bug in
	QNX.  At startup, the first mutex created has a non-zero ceiling
	priority whatever its actual policy. This makes some tests fail
	(c940013 for example).

2017-12-05  Bob Duff  <duff@adacore.com>

	* exp_ch11.adb (Expand_N_Handled_Sequence_Of_Statements): Call
	Expand_Cleanup_Actions for N_Extended_Return_Statement.
	* exp_ch7.adb (Expand_Cleanup_Actions): Handle
	N_Extended_Return_Statement by transforming the statements into a
	block, and (indirectly) calling Expand_Cleanup_Actions on the block.
	It's too hard for Expand_Cleanup_Actions to operate directly on the
	N_Extended_Return_Statement, because it has a different structure than
	the other node kinds that Expand_Cleanup_Actions.
	* exp_util.adb (Requires_Cleanup_Actions): Add support for
	N_Extended_Return_Statement.  Change "when others => return False;" to
	"when others => raise ...;" so it's clear what nodes this function
	handles.  Use named notation where appropriate.
	* exp_util.ads: Mark incorrect comment with ???.

2017-12-05  Javier Miranda  <miranda@adacore.com>

	* exp_ch9.adb (Install_Private_Data_Declarations): Add missing
	Debug_Info_Needed decoration of internally generated discriminal
	renaming declaration.

2017-12-05  Arnaud Charlet  <charlet@adacore.com>

	* exp_unst.adb (Unnest_Subprogram): Add handling of 'Access on
	nested subprograms.

2017-12-05  Sergey Rybin  <rybin@adacore.com>

	* doc/gnat_ugn/gnat_utility_programs.rst: Add description of '--ignore'
	option for gnatmetric, gnatpp, gnat2xml, and gnattest.

2017-12-05  Piotr Trojanek  <trojanek@adacore.com>

	* sem_util.adb (Contains_Refined_State): Remove.

2017-12-05  Piotr Trojanek  <trojanek@adacore.com>

	* rtsfind.ads: Add new enumeration literals: RE_Clock_Time (for
	Ada.Real_Time.Clock_Time) and RO_CA_Clock_Time (for
	Ada.Calendar.Clock_Time).

2017-12-05  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch4.adb (Is_Private_Overriding): If the candidate private
	subprogram is overloaded, scan the list of homonyms in the same
	scope, to find the inherited operation that may be overridden
	by the candidate.
	* exp_ch11.adb, exp_ch7.adb: Minor reformatting.

2017-12-05  Bob Duff  <duff@adacore.com>

	* exp_ch6.adb (Expand_N_Extended_Return_Statement): If the
	Init_Assignment is rewritten, we need to set Assignment_OK on the new
	node.  Otherwise, we will get spurious errors when initializing via
	assignment statement.

gcc/testsuite/

2017-12-05  Ed Schonberg  <schonberg@adacore.com>

	* gnat.dg/private_overriding.adb: New testcase.

From-SVN: r255414
This commit is contained in:
Pierre-Marie de Rodat 2017-12-05 12:45:35 +00:00
parent b91f986b2d
commit 40c21e918d
21 changed files with 376 additions and 269 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
gcc/ada/ChangeLog
View File

@ -1,3 +1,80 @@
2017-12-05 Piotr Trojanek <trojanek@adacore.com>
* sem_util.adb (Contains_Refined_State): Remove.
2017-12-05 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb (Analyze_Aspect_Specifications, case Predicate): A
predicate cannot apply to a formal type.
2017-12-05 Arnaud Charlet <charlet@adacore.com>
* exp_unst.ads: Fix typos.
2017-12-05 Jerome Lambourg <lambourg@adacore.com>
* libgnarl/s-taprop__qnx.adb: Better detect priority ceiling bug in
QNX. At startup, the first mutex created has a non-zero ceiling
priority whatever its actual policy. This makes some tests fail
(c940013 for example).
2017-12-05 Bob Duff <duff@adacore.com>
* exp_ch11.adb (Expand_N_Handled_Sequence_Of_Statements): Call
Expand_Cleanup_Actions for N_Extended_Return_Statement.
* exp_ch7.adb (Expand_Cleanup_Actions): Handle
N_Extended_Return_Statement by transforming the statements into a
block, and (indirectly) calling Expand_Cleanup_Actions on the block.
It's too hard for Expand_Cleanup_Actions to operate directly on the
N_Extended_Return_Statement, because it has a different structure than
the other node kinds that Expand_Cleanup_Actions.
* exp_util.adb (Requires_Cleanup_Actions): Add support for
N_Extended_Return_Statement. Change "when others => return False;" to
"when others => raise ...;" so it's clear what nodes this function
handles. Use named notation where appropriate.
* exp_util.ads: Mark incorrect comment with ???.
2017-12-05 Javier Miranda <miranda@adacore.com>
* exp_ch9.adb (Install_Private_Data_Declarations): Add missing
Debug_Info_Needed decoration of internally generated discriminal
renaming declaration.
2017-12-05 Arnaud Charlet <charlet@adacore.com>
* exp_unst.adb (Unnest_Subprogram): Add handling of 'Access on
nested subprograms.
2017-12-05 Sergey Rybin <rybin@adacore.com>
* doc/gnat_ugn/gnat_utility_programs.rst: Add description of '--ignore'
option for gnatmetric, gnatpp, gnat2xml, and gnattest.
2017-12-05 Piotr Trojanek <trojanek@adacore.com>
* sem_util.adb (Contains_Refined_State): Remove.
2017-12-05 Piotr Trojanek <trojanek@adacore.com>
* rtsfind.ads: Add new enumeration literals: RE_Clock_Time (for
Ada.Real_Time.Clock_Time) and RO_CA_Clock_Time (for
Ada.Calendar.Clock_Time).
2017-12-05 Ed Schonberg <schonberg@adacore.com>
* sem_ch4.adb (Is_Private_Overriding): If the candidate private
subprogram is overloaded, scan the list of homonyms in the same
scope, to find the inherited operation that may be overridden
by the candidate.
* exp_ch11.adb, exp_ch7.adb: Minor reformatting.
2017-12-05 Bob Duff <duff@adacore.com>
* exp_ch6.adb (Expand_N_Extended_Return_Statement): If the
Init_Assignment is rewritten, we need to set Assignment_OK on the new
node. Otherwise, we will get spurious errors when initializing via
assignment statement.
2017-12-05 Hristian Kirtchev <kirtchev@adacore.com>
* sem_elab.adb: Update the terminology and switch sections.

23
gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst
View File

@ -1400,6 +1400,11 @@ Alternatively, you may run the script using the following command line:
Each nonempty line should contain the name of an existing file.
Several such switches may be specified simultaneously.
:switch:`--ignore={filename}`
Do not process the sources listed in a specified file. This option cannot
be used in incremental mode.
:switch:`-q`
Quiet
@ -2753,6 +2758,12 @@ Alternatively, you may run the script using the following command line:
Several such switches may be specified simultaneously.
.. index:: --ignore (gnatmetric)
:switch:`--ignore={filename}`
Do not process the sources listed in a specified file.
.. index:: -j (gnatmetric)
:switch:`-j{n}`
@ -3466,6 +3477,13 @@ Alternatively, you may run the script using the following command line:
Several such switches may be specified simultaneously.
.. index:: --ignore (gnatpp)
:switch:`--ignore={filename}`
Do not process the sources listed in a specified file. This option cannot
be used in incremental mode.
.. index:: -j (gnatpp)
:switch:`-j{n}`
@ -4294,6 +4312,11 @@ Alternatively, you may run the script using the following command line:
Each nonempty line should contain the name of an existing file.
Several such switches may be specified simultaneously.
.. index:: --ignore (gnattest)
:switch:`--ignore={filename}`
Do not process the sources listed in a specified file.
.. index:: --RTS (gnattest)
:switch:`--RTS={rts-path}`

19
gcc/ada/exp_ch11.adb
View File

@ -1419,19 +1419,28 @@ package body Exp_Ch11 is
return;
end if;
-- Add clean up actions if required
-- Add cleanup actions if required. No cleanup actions are needed in
-- thunks associated with interfaces, because they only displace the
-- pointer to the object. For extended return statements, we need
-- cleanup actions if the Handled_Statement_Sequence contains generated
-- objects of controlled types, for example. We do not want to clean up
-- the return object.
if not Nkind_In (Parent (N), N_Accept_Statement,
N_Extended_Return_Statement,
N_Package_Body)
and then not Delay_Cleanups (Current_Scope)
-- No cleanup action needed in thunks associated with interfaces
-- because they only displace the pointer to the object.
and then not Is_Thunk (Current_Scope)
then
Expand_Cleanup_Actions (Parent (N));
elsif Nkind (Parent (N)) = N_Extended_Return_Statement
and then Handled_Statement_Sequence (Parent (N)) = N
and then not Delay_Cleanups (Current_Scope)
then
pragma Assert (not Is_Thunk (Current_Scope));
Expand_Cleanup_Actions (Parent (N));
else
Set_First_Real_Statement (N, First (Statements (N)));
end if;

6
gcc/ada/exp_ch6.adb
View File

@ -5370,6 +5370,10 @@ package body Exp_Ch6 is
Rewrite (Name (Init_Assignment),
Make_Explicit_Dereference (Loc,
Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc)));
pragma Assert
(Assignment_OK
(Original_Node (Name (Init_Assignment))));
Set_Assignment_OK (Name (Init_Assignment));
Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id));
@ -7310,7 +7314,7 @@ package body Exp_Ch6 is
begin
-- ???For now, enable build-in-place for a very narrow set of
-- controlled types. Change "if True" to "if False" to
-- experiment more controlled types. Eventually, we would
-- experiment with more controlled types. Eventually, we might
-- like to enable build-in-place for all tagged types, all
-- types that need finalization, and all caller-unknown-size
-- types.

105
gcc/ada/exp_ch7.adb
View File

@ -310,7 +310,7 @@ package body Exp_Ch7 is
function Build_Cleanup_Statements
(N : Node_Id;
Additional_Cleanup : List_Id) return List_Id;
-- Create the clean up calls for an asynchronous call block, task master,
-- Create the cleanup calls for an asynchronous call block, task master,
-- protected subprogram body, task allocation block or task body, or
-- additional cleanup actions parked on a transient block. If the context
-- does not contain the above constructs, the routine returns an empty
@ -479,7 +479,7 @@ package body Exp_Ch7 is
return False;
-- Do not consider C and C++ types since it is assumed that the non-Ada
-- side will handle their clean up.
-- side will handle their cleanup.
elsif Convention (Desig_Typ) = Convention_C
or else Convention (Desig_Typ) = Convention_CPP
@ -1554,8 +1554,8 @@ package body Exp_Ch7 is
Jump_Alts := New_List;
end if;
-- If the context requires additional clean up, the finalization
-- machinery is added after the clean up code.
-- If the context requires additional cleanup, the finalization
-- machinery is added after the cleanup code.
if Acts_As_Clean then
Finalizer_Stmts := Clean_Stmts;
@ -1784,7 +1784,7 @@ package body Exp_Ch7 is
end if;
-- Protect the statements with abort defer/undefer. This is only when
-- aborts are allowed and the clean up statements require deferral or
-- aborts are allowed and the cleanup statements require deferral or
-- there are controlled objects to be finalized. Note that the abort
-- defer/undefer pair does not require an extra block because each
-- finalization exception is caught in its corresponding finalization
@ -1800,7 +1800,7 @@ package body Exp_Ch7 is
-- The local exception does not need to be reraised for library-level
-- finalizers. Note that this action must be carried out after object
-- clean up, secondary stack release and abort undeferral. Generate:
-- cleanup, secondary stack release, and abort undeferral. Generate:
-- if Raised and then not Abort then
-- Raise_From_Controlled_Operation (E);
@ -1907,7 +1907,7 @@ package body Exp_Ch7 is
Append_To (Spec_Decls, Fin_Spec);
Analyze (Fin_Spec);
-- When the finalizer acts solely as a clean up routine, the body
-- When the finalizer acts solely as a cleanup routine, the body
-- is inserted right after the spec.
if Acts_As_Clean and not Has_Ctrl_Objs then
@ -4200,13 +4200,22 @@ package body Exp_Ch7 is
----------------------------
procedure Expand_Cleanup_Actions (N : Node_Id) is
pragma Assert
(Nkind_In (N,
N_Extended_Return_Statement,
N_Block_Statement,
N_Subprogram_Body,
N_Task_Body,
N_Entry_Body));
Scop : constant Entity_Id := Current_Scope;
Is_Asynchronous_Call : constant Boolean :=
Nkind (N) = N_Block_Statement
and then Is_Asynchronous_Call_Block (N);
Is_Master : constant Boolean :=
Nkind (N) /= N_Entry_Body
Nkind (N) /= N_Extended_Return_Statement
and then Nkind (N) /= N_Entry_Body
and then Is_Task_Master (N);
Is_Protected_Subp_Body : constant Boolean :=
Nkind (N) = N_Subprogram_Body
@ -4301,6 +4310,62 @@ package body Exp_Ch7 is
return;
end if;
-- If we are generating expanded code for debugging purposes, use the
-- Sloc of the point of insertion for the cleanup code. The Sloc will be
-- updated subsequently to reference the proper line in .dg files. If we
-- are not debugging generated code, use No_Location instead, so that
-- no debug information is generated for the cleanup code. This makes
-- the behavior of the NEXT command in GDB monotonic, and makes the
-- placement of breakpoints more accurate.
if Debug_Generated_Code then
Loc := Sloc (Scop);
else
Loc := No_Location;
end if;
-- If an extended return statement contains something like
-- X := F (...);
-- where F is a build-in-place function call returning a controlled
-- type, then a temporary object will be implicitly declared as part of
-- the statement list, and this will need cleanup. In such cases, we
-- transform:
--
-- return Result : T := ... do
-- <statements> -- possibly with handlers
-- end return;
--
-- into:
--
-- return Result : T := ... do
-- declare -- no declarations
-- begin
-- <statements> -- possibly with handlers
-- end; -- no handlers
-- end return;
--
-- So Expand_Cleanup_Actions will end up being called recursively on the
-- block statement.
if Nkind (N) = N_Extended_Return_Statement then
declare
Block : constant Node_Id :=
Make_Block_Statement (Loc,
Declarations => Empty_List,
Handled_Statement_Sequence =>
Handled_Statement_Sequence (N));
begin
Set_Handled_Statement_Sequence
(N, Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Block)));
Analyze (Block);
end;
-- Analysis of the block did all the work
return;
end if;
if Needs_Custom_Cleanup then
Cln := Cleanup_Actions (N);
else
@ -4315,20 +4380,6 @@ package body Exp_Ch7 is
Old_Poll : Boolean;
begin
-- If we are generating expanded code for debugging purposes, use the
-- Sloc of the point of insertion for the cleanup code. The Sloc will
-- be updated subsequently to reference the proper line in .dg files.
-- If we are not debugging generated code, use No_Location instead,
-- so that no debug information is generated for the cleanup code.
-- This makes the behavior of the NEXT command in GDB monotonic, and
-- makes the placement of breakpoints more accurate.
if Debug_Generated_Code then
Loc := Sloc (Scop);
else
Loc := No_Location;
end if;
-- Set polling off. The finalization and cleanup code is executed
-- with aborts deferred.
@ -5207,10 +5258,10 @@ package body Exp_Ch7 is
then
Loc := Sloc (Obj_Decl);
-- Before generating the clean up code for the first transient
-- Before generating the cleanup code for the first transient
-- object, create a wrapper block which houses all hook clear
-- statements and finalization calls. This wrapper is needed by
-- the back-end.
-- the back end.
if not Built then
Built := True;
@ -8680,10 +8731,10 @@ package body Exp_Ch7 is
-- Finalizer;
-- end;
-- A special case is made for Boolean expressions so that the back-end
-- A special case is made for Boolean expressions so that the back end
-- knows to generate a conditional branch instruction, if running with
-- -fpreserve-control-flow. This ensures that a control flow change
-- signalling the decision outcome occurs before the cleanup actions.
-- -fpreserve-control-flow. This ensures that a control-flow change
-- signaling the decision outcome occurs before the cleanup actions.
if Opt.Suppress_Control_Flow_Optimizations
and then Is_Boolean_Type (Typ)

6
gcc/ada/exp_ch9.adb
View File

@ -13450,6 +13450,12 @@ package body Exp_Ch9 is
Selector_Name => Make_Identifier (Loc, Chars (D))));
Add (Decl);
-- Set debug info needed on this renaming declaration even
-- though it does not come from source, so that the debugger
-- will get the right information for these generated names.
Set_Debug_Info_Needed (Discriminal (D));
Next_Discriminant (D);
end loop;
end;

36
gcc/ada/exp_unst.adb
View File

@ -574,6 +574,38 @@ package body Exp_Unst is
end if;
end if;
-- Record a 'Access as a (potential) call
elsif Nkind (N) = N_Attribute_Reference then
declare
Attr : constant Attribute_Id :=
Get_Attribute_Id (Attribute_Name (N));
begin
case Attr is
when Attribute_Access
| Attribute_Unchecked_Access
| Attribute_Unrestricted_Access
=>
Ent := Entity (Prefix (N));
-- We are only interested in calls to subprograms
-- nested within Subp.
if Scope_Within (Ent, Subp) then
if Is_Imported (Ent) then
null;
elsif Is_Subprogram (Ent) then
Append_Unique_Call
((N, Current_Subprogram, Ent));
end if;
end if;
when others =>
null;
end case;
end;
-- Record a subprogram. We record a subprogram body that acts as
-- a spec. Otherwise we record a subprogram declaration, providing
-- that it has a corresponding body we can get hold of. The case
@ -1616,7 +1648,9 @@ package body Exp_Unst is
Act : Node_Id;
begin
if Present (STT.ARECnF) then
if Present (STT.ARECnF)
and then Nkind (CTJ.N) /= N_Attribute_Reference
then
-- CTJ.N is a call to a subprogram which may require a pointer
-- to an activation record. The subprogram containing the call

6
gcc/ada/exp_unst.ads
View File

@ -64,7 +64,7 @@ package Exp_Unst is
-- doing transformations of this type.
-- Second: given that the transformation will be semantics-preserving,
-- we can still used the standard GCC back end to build code from it.
-- we can still use the standard GCC back end to build code from it.
-- This means we can easily run our full test suite to verify that the
-- transformations are indeed semantics preserving. It is a lot more
-- work to thoroughly test the output of specialized back ends.
@ -239,7 +239,7 @@ package Exp_Unst is
-- procedure inner (bb : integer; AREC1F : AREC1PT) is
-- begin
-- Integer'Deref(AREC1F.x) :=
-- Integer'Deref(AREC1F.rv) + y + b + Integer_Deref(AREC1F.b);
-- Integer'Deref(AREC1F.rv) + y + b + Integer'Deref(AREC1F.b);
-- end;
--
-- begin
@ -658,7 +658,7 @@ package Exp_Unst is
ARECnU : Entity_Id;
-- This AREC entity is the uplink component. It is other than Empty only
-- for nested subprograms that declare an activation record as indicated
-- by Declares_AREC being Ture, and which have uplevel references (Lev
-- by Declares_AREC being True, and which have uplevel references (Lev
-- greater than Uplevel_Ref). It is the additional component in the
-- activation record that references the ARECnF pointer (which points
-- the activation record one level higher, thus forming the chain).

37
gcc/ada/exp_util.adb
View File

@ -10701,7 +10701,9 @@ package body Exp_Util is
and then not Is_Empty_List (Then_Statements (N))
and then not Are_Wrapped (Then_Statements (N))
and then Requires_Cleanup_Actions
(Then_Statements (N), False, False)
(Then_Statements (N),
Lib_Level => False,
Nested_Constructs => False)
then
Block := Wrap_Statements_In_Block (Then_Statements (N));
Set_Then_Statements (N, New_List (Block));
@ -10718,7 +10720,9 @@ package body Exp_Util is
and then not Is_Empty_List (Else_Statements (N))
and then not Are_Wrapped (Else_Statements (N))
and then Requires_Cleanup_Actions
(Else_Statements (N), False, False)
(Else_Statements (N),
Lib_Level => False,
Nested_Constructs => False)
then
Block := Wrap_Statements_In_Block (Else_Statements (N));
Set_Else_Statements (N, New_List (Block));
@ -10737,7 +10741,10 @@ package body Exp_Util is
=>
if not Is_Empty_List (Statements (N))
and then not Are_Wrapped (Statements (N))
and then Requires_Cleanup_Actions (Statements (N), False, False)
and then Requires_Cleanup_Actions
(Statements (N),
Lib_Level => False,
Nested_Constructs => False)
then
if Nkind (N) = N_Loop_Statement
and then Present (Identifier (N))
@ -11815,24 +11822,38 @@ package body Exp_Util is
| N_Task_Body
=>
return
Requires_Cleanup_Actions (Declarations (N), At_Lib_Level, True)
Requires_Cleanup_Actions
(Declarations (N), At_Lib_Level, Nested_Constructs => True)
or else
(Present (Handled_Statement_Sequence (N))
and then
Requires_Cleanup_Actions
(Statements (Handled_Statement_Sequence (N)),
At_Lib_Level, True));
At_Lib_Level, Nested_Constructs => True));
-- Extended return statements are the same as the above, except that
-- there is no Declarations field. We do not want to clean up the
-- Return_Object_Declarations.
when N_Extended_Return_Statement =>
return
Present (Handled_Statement_Sequence (N))
and then Requires_Cleanup_Actions
(Statements (Handled_Statement_Sequence (N)),
At_Lib_Level, Nested_Constructs => True);
when N_Package_Specification =>
return
Requires_Cleanup_Actions
(Visible_Declarations (N), At_Lib_Level, True)
(Visible_Declarations (N), At_Lib_Level,
Nested_Constructs => True)
or else
Requires_Cleanup_Actions
(Private_Declarations (N), At_Lib_Level, True);
(Private_Declarations (N), At_Lib_Level,
Nested_Constructs => True);
when others =>
return False;
raise Program_Error;
end case;
end Requires_Cleanup_Actions;

4
gcc/ada/exp_util.ads
View File

@ -52,7 +52,9 @@ package Exp_Util is
-- For an expression occurring in a declaration (declarations always
-- appear in lists), the actions are similarly inserted into the list
-- just before the associated declaration.
-- just before the associated declaration. ???Declarations do not always
-- appear in lists; in particular, a library unit declaration does not
-- appear in a list, and Insert_Action will crash in that case.
-- The following special cases arise:

7
gcc/ada/libgnarl/s-taprop__qnx.adb
View File

@ -442,16 +442,15 @@ package body System.Task_Primitives.Operations is
-- Workaround bug in QNX on ceiling locks: tasks with priority higher
-- than the ceiling priority don't receive EINVAL upon trying to lock.
if Result = 0 then
if Result = 0 and then Locking_Policy = 'C' then
Result := pthread_getschedparam (Self, Policy'Access, Sched'Access);
pragma Assert (Result = 0);
Result := pthread_mutex_getprioceiling (L.WO'Access, Ceiling'Access);
pragma Assert (Result = 0);
-- Ceiling = 0 means no Ceiling Priority policy is set on this mutex
-- Else, Ceiling < current priority means Ceiling violation
-- Ceiling < current priority means Ceiling violation
-- (otherwise the current priority == ceiling)
if Ceiling > 0 and then Ceiling < Sched.sched_curpriority then
if Ceiling < Sched.sched_curpriority then
Ceiling_Violation := True;
Result := pthread_mutex_unlock (L.WO'Access);
pragma Assert (Result = 0);

2
gcc/ada/libgnat/s-regexp.ads
View File

@ -41,7 +41,7 @@
with Ada.Finalization;
package System.Regexp is
package System.Regexp is -- ????????????????
-- The regular expression must first be compiled, using the Compile
-- function, which creates a finite state matching table, allowing

2
gcc/ada/opt.ads
View File

@ -1445,7 +1445,7 @@ package Opt is
-- GNAT.Exception_Traces is with'ed. Used to inhibit transformation of
-- local raise statements into gotos in the presence of either package.
Sprint_Line_Limit : Nat := 72;
Sprint_Line_Limit : Nat := 72; -- ????????????????
-- GNAT
-- Limit values for chopping long lines in Cprint/Sprint output, can be
-- reset by use of NNN parameter with -gnatG or -gnatD switches.

4
gcc/ada/rtsfind.ads
View File

@ -543,6 +543,7 @@ package Rtsfind is
RE_Null,
RO_CA_Time, -- Ada.Calendar
RO_CA_Clock_Time, -- Ada.Calendar
RO_CA_Delay_For, -- Ada.Calendar.Delays
RO_CA_Delay_Until, -- Ada.Calendar.Delays
@ -582,6 +583,7 @@ package Rtsfind is
RE_Names, -- Ada.Interrupts.Names
RE_Clock, -- Ada.Real_Time
RE_Clock_Time, -- Ada.Real_Time
RE_Time_Span, -- Ada.Real_Time
RE_Time_Span_Zero, -- Ada.Real_Time
RO_RT_Time, -- Ada.Real_Time
@ -1779,6 +1781,7 @@ package Rtsfind is
RE_Null => RTU_Null,
RO_CA_Time => Ada_Calendar,
RO_CA_Clock_Time => Ada_Calendar,
RO_CA_Delay_For => Ada_Calendar_Delays,
RO_CA_Delay_Until => Ada_Calendar_Delays,
@ -1818,6 +1821,7 @@ package Rtsfind is
RE_Names => Ada_Interrupts_Names,
RE_Clock => Ada_Real_Time,
RE_Clock_Time => Ada_Real_Time,
RE_Time_Span => Ada_Real_Time,
RE_Time_Span_Zero => Ada_Real_Time,
RO_RT_Time => Ada_Real_Time,

4
gcc/ada/sem_ch13.adb
View File

@ -2389,6 +2389,10 @@ package body Sem_Ch13 is
elsif Is_Incomplete_Type (E) then
Error_Msg_N
("predicate cannot apply to incomplete view", Aspect);
elsif Is_Generic_Type (E) then
Error_Msg_N
("predicate cannot apply to formal type", Aspect);
goto Continue;
end if;

29
gcc/ada/sem_ch4.adb
View File

@ -9411,14 +9411,31 @@ package body Sem_Ch4 is
---------------------------
function Is_Private_Overriding (Op : Entity_Id) return Boolean is
Visible_Op : constant Entity_Id := Homonym (Op);
Visible_Op : Entity_Id;
begin
return Present (Visible_Op)
and then Scope (Op) = Scope (Visible_Op)
and then not Comes_From_Source (Visible_Op)
and then Alias (Visible_Op) = Op
and then not Is_Hidden (Visible_Op);
-- The subprogram may be overloaded with both visible and private
-- entities with the same name. We have to scan the chain of
-- homonyms to determine whether there is a previous implicit
-- declaration in the same scope that is overridden by the
-- private candidate.
Visible_Op := Homonym (Op);
while Present (Visible_Op) loop
if Scope (Op) /= Scope (Visible_Op) then
return False;
elsif not Comes_From_Source (Visible_Op)
and then Alias (Visible_Op) = Op
and then not Is_Hidden (Visible_Op)
then
return True;
end if;
Visible_Op := Homonym (Visible_Op);
end loop;
return False;
end Is_Private_Overriding;
-----------------

203
gcc/ada/sem_util.adb
View File

@ -5296,209 +5296,6 @@ package body Sem_Util is
end if;
end Conditional_Delay;
----------------------------
-- Contains_Refined_State --
----------------------------
function Contains_Refined_State (Prag : Node_Id) return Boolean is
function Has_State_In_Dependency (List : Node_Id) return Boolean;
-- Determine whether a dependency list mentions a state with a visible
-- refinement.
function Has_State_In_Global (List : Node_Id) return Boolean;
-- Determine whether a global list mentions a state with a visible
-- refinement.
function Is_Refined_State (Item : Node_Id) return Boolean;
-- Determine whether Item is a reference to an abstract state with a
-- visible refinement.
-----------------------------
-- Has_State_In_Dependency --
-----------------------------
function Has_State_In_Dependency (List : Node_Id) return Boolean is
Clause : Node_Id;
Output : Node_Id;
begin
-- A null dependency list does not mention any states
if Nkind (List) = N_Null then
return False;
-- Dependency clauses appear as component associations of an
-- aggregate.
elsif Nkind (List) = N_Aggregate
and then Present (Component_Associations (List))
then
Clause := First (Component_Associations (List));
while Present (Clause) loop
-- Inspect the outputs of a dependency clause
Output := First (Choices (Clause));
while Present (Output) loop
if Is_Refined_State (Output) then
return True;
end if;
Next (Output);
end loop;
-- Inspect the outputs of a dependency clause
if Is_Refined_State (Expression (Clause)) then
return True;
end if;
Next (Clause);
end loop;
-- If we get here, then none of the dependency clauses mention a
-- state with visible refinement.
return False;
-- An illegal pragma managed to sneak in
else
raise Program_Error;
end if;
end Has_State_In_Dependency;
-------------------------
-- Has_State_In_Global --
-------------------------
function Has_State_In_Global (List : Node_Id) return Boolean is
Item : Node_Id;
begin
-- A null global list does not mention any states
if Nkind (List) = N_Null then
return False;
-- Simple global list or moded global list declaration
elsif Nkind (List) = N_Aggregate then
-- The declaration of a simple global list appear as a collection
-- of expressions.
if Present (Expressions (List)) then
Item := First (Expressions (List));
while Present (Item) loop
if Is_Refined_State (Item) then
return True;
end if;
Next (Item);
end loop;
-- The declaration of a moded global list appears as a collection
-- of component associations where individual choices denote
-- modes.
else
Item := First (Component_Associations (List));
while Present (Item) loop
if Has_State_In_Global (Expression (Item)) then
return True;
end if;
Next (Item);
end loop;
end if;
-- If we get here, then the simple/moded global list did not
-- mention any states with a visible refinement.
return False;
-- Single global item declaration
elsif Is_Entity_Name (List) then
return Is_Refined_State (List);
-- An illegal pragma managed to sneak in
else
raise Program_Error;
end if;
end Has_State_In_Global;
----------------------
-- Is_Refined_State --
----------------------
function Is_Refined_State (Item : Node_Id) return Boolean is
Elmt : Node_Id;
Item_Id : Entity_Id;
begin
if Nkind (Item) = N_Null then
return False;
-- States cannot be subject to attribute 'Result. This case arises
-- in dependency relations.
elsif Nkind (Item) = N_Attribute_Reference
and then Attribute_Name (Item) = Name_Result
then
return False;
-- Multiple items appear as an aggregate. This case arises in
-- dependency relations.
elsif Nkind (Item) = N_Aggregate
and then Present (Expressions (Item))
then
Elmt := First (Expressions (Item));
while Present (Elmt) loop
if Is_Refined_State (Elmt) then
return True;
end if;
Next (Elmt);
end loop;
-- If we get here, then none of the inputs or outputs reference a
-- state with visible refinement.
return False;
-- Single item
else
Item_Id := Entity_Of (Item);
return
Present (Item_Id)
and then Ekind (Item_Id) = E_Abstract_State
and then Has_Visible_Refinement (Item_Id);
end if;
end Is_Refined_State;
-- Local variables
Arg : constant Node_Id :=
Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
Nam : constant Name_Id := Pragma_Name (Prag);
-- Start of processing for Contains_Refined_State
begin
if Nam = Name_Depends then
return Has_State_In_Dependency (Arg);
else pragma Assert (Nam = Name_Global);
return Has_State_In_Global (Arg);
end if;
end Contains_Refined_State;
-------------------------
-- Copy_Component_List --
-------------------------

7
gcc/ada/sem_util.ads
View File

@ -480,13 +480,6 @@ package Sem_Util is
-- of Old_Ent is set and Old_Ent has not yet been Frozen (i.e. Is_Frozen is
-- False).
function Contains_Refined_State (Prag : Node_Id) return Boolean;
-- Determine whether pragma Prag contains a reference to the entity of an
-- abstract state with a visible refinement. Prag must denote one of the
-- following pragmas:
-- Depends
-- Global
function Copy_Component_List
(R_Typ : Entity_Id;
Loc : Source_Ptr) return List_Id;

2
gcc/ada/types.ads
View File

@ -49,7 +49,7 @@ with System;
with Unchecked_Conversion;
with Unchecked_Deallocation;
package Types is
package Types is -- ????????????????
pragma Preelaborate;
-------------------------------

4
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,7 @@
2017-12-05 Ed Schonberg <schonberg@adacore.com>
* gnat.dg/private_overriding.adb: New testcase.
2017-12-05 Martin Liska <mliska@suse.cz>
Jakub Jelinek <jakub@redhat.com>

62
gcc/testsuite/gnat.dg/private_overriding.adb Normal file
View File

@ -0,0 +1,62 @@
-- { dg-do compile }
procedure Private_Overriding is
package Foo is
type Bar is abstract tagged null record;
procedure Overloaded_Subprogram
(Self : in out Bar)
is abstract;
procedure Overloaded_Subprogram
(Self : in out Bar;
P1 : Integer)
is abstract;
procedure Not_Overloaded_Subprogram
(Self : in out Bar)
is abstract;
type Baz is new Bar with null record;
-- promise to override both overloaded subprograms,
-- shouldn't matter that they're defined in the private part,
private -- workaround: override in the public view
overriding
procedure Overloaded_Subprogram
(Self : in out Baz)
is null;
overriding
procedure Overloaded_Subprogram
(Self : in out Baz;
P1 : Integer)
is null;
overriding
procedure Not_Overloaded_Subprogram
(Self : in out Baz)
is null;
end Foo;
Qux : Foo.Baz;
begin
-- this is allowed, as expected
Foo.Not_Overloaded_Subprogram(Qux);
Foo.Overloaded_Subprogram(Qux);
Foo.Overloaded_Subprogram(Foo.Baz'Class(Qux));
Foo.Overloaded_Subprogram(Foo.Bar'Class(Qux));
-- however, using object-dot notation
Qux.Not_Overloaded_Subprogram; -- this is allowed
Qux.Overloaded_Subprogram; -- "no selector..."
Foo.Baz'Class(Qux).Overloaded_Subprogram; -- "no selector..."
Foo.Bar'Class(Qux).Overloaded_Subprogram; -- this is allowed
end Private_Overriding;