+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.
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
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}`
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}`
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}`
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;
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));
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.
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
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
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;
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
-- 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);
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
----------------------------
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
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
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.
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;
-- 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)
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;
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
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
-- 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.
-- 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
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).
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));
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));
=>
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))
| 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;
-- 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:
-- 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);
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
-- 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.
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
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
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,
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,
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;
---------------------------
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;
-----------------
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 --
-------------------------
-- 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;
with Unchecked_Conversion;
with Unchecked_Deallocation;
-package Types is
+package Types is -- ????????????????
pragma Preelaborate;
-------------------------------
+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>
--- /dev/null
+-- { 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;
projects / platform / upstream / gcc.git / commitdiff