mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-04 15:41:21 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2010-10-22  Thomas Quinot  <quinot@adacore.com>

	* einfo.ads (Declaration_Node): Clarify documentation, in particular
	regarding what is returned for subprogram entities.

2010-10-22  Arnaud Charlet  <charlet@adacore.com>

	* exp_attr.adb (Make_Range_Test): Generate a Range node instead of
	explicit comparisons, generates simpler expanded code.
	* a-except-2005.adb (Rcheck_06_Ext): New.
	* gcc-interface/trans.c (gigi, gnat_to_gnu): Handle validity checks
	like range checks.
	* gcc-interface/Make-lang.in: Update dependencies.

2010-10-22  Robert Dewar  <dewar@adacore.com>

	* sem_ch3.adb (Array_Type_Declaration): Error for subtype wi predicate
	for index type
	(Constrain_Index): Error of subtype wi predicate in index constraint
	* sem_ch9.adb (Analyze_Entry_Declaration): Error of subtype wi
	predicate in entry family.
	* sem_res.adb (Resolve_Slice): Error of type wi predicate in slice.

2010-10-22  Javier Miranda  <miranda@adacore.com>

	* sem_util.ads, sem_util.adb (Collect_Parents): New subprogram.
	(Original_Corresponding_Operation): New subprogram.
	(Visible_Ancestors): New subprogram.
	* sem_ch6.adb (New_Overloaded_Entity): Handle new case of dispatching
	operation that overrides a hidden inherited primitive.
	* sem_disp.adb (Find_Hidden_Overridden_Primitive): New subprogram.
	(Check_Dispatching_Operation): if the new dispatching operation
	does not override a visible primtive then check if it overrides
	some hidden inherited primitive.

2010-10-22  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch10.adb (Analyze_With_Clause): If the parent_unit_name in a with
	clause is a child unit that denotes a renaming, replace the
	parent_unit_name with a reference to the renamed unit, because the
	prefix is irrelevant to subsequent visibility..

From-SVN: r165805
This commit is contained in:
Arnaud Charlet 2010-10-22 11:14:01 +02:00
parent 2d4e055322
commit ea0342360d
14 changed files with 415 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
gcc/ada/ChangeLog
View File

@ -1,3 +1,45 @@
2010-10-22 Thomas Quinot <quinot@adacore.com>
* einfo.ads (Declaration_Node): Clarify documentation, in particular
regarding what is returned for subprogram entities.
2010-10-22 Arnaud Charlet <charlet@adacore.com>
* exp_attr.adb (Make_Range_Test): Generate a Range node instead of
explicit comparisons, generates simpler expanded code.
* a-except-2005.adb (Rcheck_06_Ext): New.
* gcc-interface/trans.c (gigi, gnat_to_gnu): Handle validity checks
like range checks.
* gcc-interface/Make-lang.in: Update dependencies.
2010-10-22 Robert Dewar <dewar@adacore.com>
* sem_ch3.adb (Array_Type_Declaration): Error for subtype wi predicate
for index type
(Constrain_Index): Error of subtype wi predicate in index constraint
* sem_ch9.adb (Analyze_Entry_Declaration): Error of subtype wi
predicate in entry family.
* sem_res.adb (Resolve_Slice): Error of type wi predicate in slice.
2010-10-22 Javier Miranda <miranda@adacore.com>
* sem_util.ads, sem_util.adb (Collect_Parents): New subprogram.
(Original_Corresponding_Operation): New subprogram.
(Visible_Ancestors): New subprogram.
* sem_ch6.adb (New_Overloaded_Entity): Handle new case of dispatching
operation that overrides a hidden inherited primitive.
* sem_disp.adb (Find_Hidden_Overridden_Primitive): New subprogram.
(Check_Dispatching_Operation): if the new dispatching operation
does not override a visible primtive then check if it overrides
some hidden inherited primitive.
2010-10-22 Ed Schonberg <schonberg@adacore.com>
* sem_ch10.adb (Analyze_With_Clause): If the parent_unit_name in a with
clause is a child unit that denotes a renaming, replace the
parent_unit_name with a reference to the renamed unit, because the
prefix is irrelevant to subsequent visibility..
2010-10-22 Robert Dewar <dewar@adacore.com>
* einfo.ads, einfo.adb (Has_Predicates): Flag is now on all entities

15
gcc/ada/a-except-2005.adb
View File

@ -469,6 +469,8 @@ package body Ada.Exceptions is
(File : System.Address; Line, Column : Integer);
procedure Rcheck_05_Ext
(File : System.Address; Line, Column, Index, First, Last : Integer);
procedure Rcheck_06_Ext
(File : System.Address; Line, Column, Index, First, Last : Integer);
procedure Rcheck_12_Ext
(File : System.Address; Line, Column, Index, First, Last : Integer);
@ -509,6 +511,7 @@ package body Ada.Exceptions is
pragma Export (C, Rcheck_00_Ext, "__gnat_rcheck_00_ext");
pragma Export (C, Rcheck_05_Ext, "__gnat_rcheck_05_ext");
pragma Export (C, Rcheck_06_Ext, "__gnat_rcheck_06_ext");
pragma Export (C, Rcheck_12_Ext, "__gnat_rcheck_12_ext");
-- None of these procedures ever returns (they raise an exception!). By
@ -551,6 +554,7 @@ package body Ada.Exceptions is
pragma No_Return (Rcheck_00_Ext);
pragma No_Return (Rcheck_05_Ext);
pragma No_Return (Rcheck_06_Ext);
pragma No_Return (Rcheck_12_Ext);
---------------------------------------------
@ -1236,6 +1240,17 @@ package body Ada.Exceptions is
Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
end Rcheck_05_Ext;
procedure Rcheck_06_Ext
(File : System.Address; Line, Column, Index, First, Last : Integer)
is
Msg : constant String :=
Rmsg_06 (Rmsg_06'First .. Rmsg_06'Last - 1) & ASCII.LF &
"value " & Image (Index) & " not in " & Image (First) &
".." & Image (Last) & ASCII.NUL;
begin
Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
end Rcheck_06_Ext;
procedure Rcheck_12_Ext
(File : System.Address; Line, Column, Index, First, Last : Integer)
is

16
gcc/ada/einfo.ads
View File

@ -692,13 +692,15 @@ package Einfo is
-- details of the use of this field.
-- Declaration_Node (synthesized)
-- Applies to all entities. Returns the tree node for the declaration
-- that declared the entity. Normally this is just the Parent of the
-- entity. One exception arises with child units, where the parent of
-- the entity is a selected component or a defining program unit name.
-- Another exception is that if the entity is an incomplete type that
-- has been completed, then we obtain the declaration node denoted by
-- the full type, i.e. the full type declaration node.
-- Applies to all entities. Returns the tree node for the construct that
-- declared the entity. Normally this is just the Parent of the entity.
-- One exception arises with child units, where the parent of the entity
-- is a selected component/defining program unit name. Another exception
-- is that if the entity is an incomplete type that has been completed,
-- then we obtain the declaration node denoted by the full type, i.e. the
-- full type declaration node. Also note that for subprograms, this
-- returns the {function,procedure}_specification, not the subprogram_
-- declaration.
-- Default_Expr_Function (Node21)
-- Present in parameters. It holds the entity of the parameterless

27
gcc/ada/exp_attr.adb
View File

@ -4711,9 +4711,7 @@ package body Exp_Attr is
function Make_Range_Test return Node_Id;
-- Build the code for a range test of the form
-- Btyp!(Pref) >= Btyp!(Ptyp'First)
-- and then
-- Btyp!(Pref) <= Btyp!(Ptyp'Last)
-- Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last)
---------------------
-- Make_Range_Test --
@ -4732,24 +4730,17 @@ package body Exp_Attr is
end if;
return
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Ge (Loc,
Left_Opnd =>
Unchecked_Convert_To (Btyp, Temp),
Right_Opnd =>
Make_In (Loc,
Left_Opnd =>
Unchecked_Convert_To (Btyp, Temp),
Right_Opnd =>
Make_Range (Loc,
Low_Bound =>
Unchecked_Convert_To (Btyp,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_First))),
Right_Opnd =>
Make_Op_Le (Loc,
Left_Opnd =>
Unchecked_Convert_To (Btyp, Temp),
Right_Opnd =>
Attribute_Name => Name_First)),
High_Bound =>
Unchecked_Convert_To (Btyp,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Ptyp, Loc),

29
gcc/ada/gcc-interface/Make-lang.in
View File

@ -1797,20 +1797,21 @@ ada/exp_ch12.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/exp_ch13.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \
ada/einfo.adb ada/elists.ads ada/elists.adb ada/exp_ch13.ads \
ada/exp_ch13.adb ada/exp_ch3.ads ada/exp_ch6.ads ada/exp_imgv.ads \
ada/exp_tss.ads ada/exp_util.ads ada/gnat.ads ada/g-htable.ads \
ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \
ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/rtsfind.ads \
ada/sem.ads ada/sem_aux.ads ada/sem_ch3.ads ada/sem_ch7.ads \
ada/sem_ch8.ads ada/sem_eval.ads ada/sem_util.ads ada/sinfo.ads \
ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \
ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \
ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \
ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
ada/table.ads ada/table.adb ada/tbuild.ads ada/tree_io.ads \
ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \
ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \
ada/errout.ads ada/erroutc.ads ada/exp_ch13.ads ada/exp_ch13.adb \
ada/exp_ch3.ads ada/exp_ch6.ads ada/exp_imgv.ads ada/exp_tss.ads \
ada/exp_util.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \
ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \
ada/opt.ads ada/output.ads ada/rtsfind.ads ada/sem.ads ada/sem_aux.ads \
ada/sem_ch3.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_eval.ads \
ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \
ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \
ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \
ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \
ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \
ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \
ada/validsw.ads
ada/exp_ch2.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \

8
gcc/ada/gcc-interface/trans.c
View File

@ -482,8 +482,9 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED,
gnat_raise_decls_ext[i]
= build_raise_check (i, t,
i == CE_Index_Check_Failed
|| i == CE_Range_Check_Failed ?
exception_range : exception_column);
|| i == CE_Range_Check_Failed
|| i == CE_Invalid_Data
? exception_range : exception_column);
}
/* Set the types that GCC and Gigi use from the front end. */
@ -5518,7 +5519,8 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_result = build_call_raise_column (reason, gnat_node);
}
else if ((reason == CE_Index_Check_Failed
|| reason == CE_Range_Check_Failed)
|| reason == CE_Range_Check_Failed
|| reason == CE_Invalid_Data)
&& Nkind (cond) == N_Op_Not
&& Nkind (Right_Opnd (cond)) == N_In
&& Nkind (Right_Opnd (Right_Opnd (cond))) == N_Range)

16
gcc/ada/sem_ch10.adb
View File

@ -2556,6 +2556,22 @@ package body Sem_Ch10 is
Par_Name := Scope (E_Name);
while Nkind (Pref) = N_Selected_Component loop
Change_Selected_Component_To_Expanded_Name (Pref);
if Present (Entity (Selector_Name (Pref)))
and then
Present (Renamed_Entity (Entity (Selector_Name (Pref))))
and then Entity (Selector_Name (Pref)) /= Par_Name
then
-- The prefix is a child unit that denotes a renaming
-- declaration. Replace the prefix directly with the renamed
-- unit, because the rest of the prefix is irrelevant to the
-- visibility of the real unit.
Rewrite (Pref, New_Occurrence_Of (Par_Name, Sloc (Pref)));
exit;
end if;
Set_Entity_With_Style_Check (Pref, Par_Name);
Generate_Reference (Par_Name, Pref);

20
gcc/ada/sem_ch3.adb
View File

@ -446,7 +446,7 @@ package body Sem_Ch3 is
Related_Id : Entity_Id;
Suffix : Character;
Suffix_Index : Nat);
-- Process an index constraint in a constrained array declaration. The
-- Process an index constraint S in a constrained array declaration. The
-- constraint can be a subtype name, or a range with or without an explicit
-- subtype mark. The index is the corresponding index of the unconstrained
-- array. The Related_Id and Suffix parameters are used to build the
@ -4424,6 +4424,17 @@ package body Sem_Ch3 is
end if;
Make_Index (Index, P, Related_Id, Nb_Index);
-- Check error of subtype with predicate for index type
if Has_Predicates (Etype (Index)) then
Error_Msg_NE
("subtype& has predicate, not allowed as index subtype",
Index, Etype (Index));
end if;
-- Move to next index
Next_Index (Index);
Nb_Index := Nb_Index + 1;
end loop;
@ -11332,6 +11343,13 @@ package body Sem_Ch3 is
elsif Base_Type (Entity (S)) /= Base_Type (T) then
Wrong_Type (S, Base_Type (T));
-- Check error of subtype with predicate in index constraint
elsif Has_Predicates (Entity (S)) then
Error_Msg_NE
("subtype& has predicate, not allowed in index consraint",
S, Entity (S));
end if;
return;

14
gcc/ada/sem_ch6.adb
View File

@ -7824,6 +7824,20 @@ package body Sem_Ch6 is
if Comes_From_Source (S) then
Check_Synchronized_Overriding (S, Overridden_Subp);
-- (Ada 2012: AI05-0125-1): If S is a dispatching operation then
-- it may have overridden some hidden inherited primitive. Update
-- Overriden_Subp to avoid spurious errors when checking the
-- overriding indicator.
if Ada_Version >= Ada_2012
and then No (Overridden_Subp)
and then Is_Dispatching_Operation (S)
and then Is_Overriding_Operation (S)
then
Overridden_Subp := Overridden_Operation (S);
end if;
Check_Overriding_Indicator
(S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp);
end if;

17
gcc/ada/sem_ch9.adb
View File

@ -879,19 +879,36 @@ package body Sem_Ch9 is
Generate_Definition (Def_Id);
Tasking_Used := True;
-- Case of no discrete subtype definition
if No (D_Sdef) then
Set_Ekind (Def_Id, E_Entry);
-- Processing for discrete subtype definition present
else
Enter_Name (Def_Id);
Set_Ekind (Def_Id, E_Entry_Family);
Analyze (D_Sdef);
Make_Index (D_Sdef, N, Def_Id);
-- Check subtype with predicate in entry family
if Has_Predicates (Etype (D_Sdef)) then
Error_Msg_NE
("subtype& has predicate, not allowed in entry family",
D_Sdef, Etype (D_Sdef));
end if;
end if;
-- Decorate Def_Id
Set_Etype (Def_Id, Standard_Void_Type);
Set_Convention (Def_Id, Convention_Entry);
Set_Accept_Address (Def_Id, New_Elmt_List);
-- Process formals
if Present (Formals) then
Set_Scope (Def_Id, Current_Scope);
Push_Scope (Def_Id);

119
gcc/ada/sem_disp.adb
View File

@ -72,6 +72,18 @@ package body Sem_Disp is
-- (returning the designated tagged type in the case of an access
-- parameter); otherwise returns empty.
function Find_Hidden_Overridden_Primitive (S : Entity_Id) return Entity_Id;
-- [Ada 2012:AI-0125] Find an inherited hidden primitive of the dispatching
-- type of S that has the same name of S, a type-conformant profile, an
-- original corresponding operation O that is a primitive of a visible
-- ancestor of the dispatching type of S and O is visible at the point of
-- of declaration of S. If the entity is found the Alias of S is set to the
-- original corresponding operation S and its Overridden_Operation is set
-- to the found entity; otherwise return Empty.
--
-- This routine does not search for non-hidden primitives since they are
-- covered by the normal Ada 2005 rules.
-------------------------------
-- Add_Dispatching_Operation --
-------------------------------
@ -741,8 +753,9 @@ package body Sem_Disp is
procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is
Tagged_Type : Entity_Id;
Has_Dispatching_Parent : Boolean := False;
Body_Is_Last_Primitive : Boolean := False;
Has_Dispatching_Parent : Boolean := False;
Body_Is_Last_Primitive : Boolean := False;
Ovr_Subp : Entity_Id := Empty;
begin
if not Ekind_In (Subp, E_Procedure, E_Function) then
@ -1078,14 +1091,25 @@ package body Sem_Disp is
Check_Controlling_Formals (Tagged_Type, Subp);
Ovr_Subp := Old_Subp;
-- [Ada 2012:AI-0125]: Search for inherited hidden primitive that may be
-- overridden by Subp
if No (Ovr_Subp)
and then Ada_Version >= Ada_2012
then
Ovr_Subp := Find_Hidden_Overridden_Primitive (Subp);
end if;
-- Now it should be a correct primitive operation, put it in the list
if Present (Old_Subp) then
if Present (Ovr_Subp) then
-- If the type has interfaces we complete this check after we set
-- attribute Is_Dispatching_Operation.
Check_Subtype_Conformant (Subp, Old_Subp);
Check_Subtype_Conformant (Subp, Ovr_Subp);
if (Chars (Subp) = Name_Initialize
or else Chars (Subp) = Name_Adjust
@ -1114,7 +1138,7 @@ package body Sem_Disp is
end if;
else
Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
Override_Dispatching_Operation (Tagged_Type, Ovr_Subp, Subp);
Set_Is_Overriding_Operation (Subp);
-- Ada 2005 (AI-251): In case of late overriding of a primitive
@ -1183,7 +1207,7 @@ package body Sem_Disp is
-- subtype conformance against all the interfaces covered by this
-- primitive.
if Present (Old_Subp)
if Present (Ovr_Subp)
and then Has_Interfaces (Tagged_Type)
then
declare
@ -1649,6 +1673,89 @@ package body Sem_Disp is
return Empty;
end Find_Dispatching_Type;
--------------------------------------
-- Find_Hidden_Overridden_Primitive --
--------------------------------------
function Find_Hidden_Overridden_Primitive (S : Entity_Id) return Entity_Id
is
Tag_Typ : constant Entity_Id := Find_Dispatching_Type (S);
Elmt : Elmt_Id;
Orig_Prim : Entity_Id;
Prim : Entity_Id;
Vis_List : Elist_Id;
begin
-- This Ada 2012 rule is valid only for type extensions or private
-- extensions
if No (Tag_Typ)
or else not Is_Record_Type (Tag_Typ)
or else Etype (Tag_Typ) = Tag_Typ
then
return Empty;
end if;
-- Collect the list of visible ancestor of the tagged type
Vis_List := Visible_Ancestors (Tag_Typ);
Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
while Present (Elmt) loop
Prim := Node (Elmt);
-- Find an inherited hidden dispatching primitive with the name of S
-- and a type-conformant profile
if Present (Alias (Prim))
and then Is_Hidden (Alias (Prim))
and then Find_Dispatching_Type (Alias (Prim)) /= Tag_Typ
and then Primitive_Names_Match (S, Prim)
and then Type_Conformant (S, Prim)
then
declare
Vis_Ancestor : Elmt_Id;
Elmt : Elmt_Id;
begin
-- The original corresponding operation of Prim must be an
-- operation of a visible ancestor of the dispatching type
-- of S, and the original corresponding operation of S2 must
-- be visible.
Orig_Prim := Original_Corresponding_Operation (Prim);
if Orig_Prim /= Prim
and then Is_Immediately_Visible (Orig_Prim)
then
Vis_Ancestor := First_Elmt (Vis_List);
while Present (Vis_Ancestor) loop
Elmt :=
First_Elmt (Primitive_Operations (Node (Vis_Ancestor)));
while Present (Elmt) loop
if Node (Elmt) = Orig_Prim then
Set_Overridden_Operation (S, Prim);
Set_Alias (Prim, Orig_Prim);
return Prim;
end if;
Next_Elmt (Elmt);
end loop;
Next_Elmt (Vis_Ancestor);
end loop;
end if;
end;
end if;
Next_Elmt (Elmt);
end loop;
return Empty;
end Find_Hidden_Overridden_Primitive;
---------------------------------------
-- Find_Primitive_Covering_Interface --
---------------------------------------

11
gcc/ada/sem_res.adb
View File

@ -8478,7 +8478,16 @@ package body Sem_Res is
Set_Slice_Subtype (N);
if Nkind (Drange) = N_Range then
-- Check bad use of type with predicates
if Has_Predicates (Etype (Drange)) then
Error_Msg_NE
("subtype& has predicate, not allowed in slice",
Drange, Etype (Drange));
-- Otherwise here is where we check suspicious indexes
elsif Nkind (Drange) = N_Range then
Warn_On_Suspicious_Index (Name, Low_Bound (Drange));
Warn_On_Suspicious_Index (Name, High_Bound (Drange));
end if;

111
gcc/ada/sem_util.adb
View File

@ -1679,6 +1679,44 @@ package body Sem_Util is
end loop;
end Collect_Interfaces_Info;
---------------------
-- Collect_Parents --
---------------------
procedure Collect_Parents
(T : Entity_Id;
List : out Elist_Id;
Use_Full_View : Boolean := True)
is
Current_Typ : Entity_Id := T;
Parent_Typ : Entity_Id;
begin
List := New_Elmt_List;
-- No action if the if the type has no parents
if T = Etype (T) then
return;
end if;
loop
Parent_Typ := Etype (Current_Typ);
if Is_Private_Type (Parent_Typ)
and then Present (Full_View (Parent_Typ))
and then Use_Full_View
then
Parent_Typ := Full_View (Base_Type (Parent_Typ));
end if;
Append_Elmt (Parent_Typ, List);
exit when Parent_Typ = Current_Typ;
Current_Typ := Parent_Typ;
end loop;
end Collect_Parents;
----------------------------------
-- Collect_Primitive_Operations --
----------------------------------
@ -9790,6 +9828,38 @@ package body Sem_Util is
end if;
end Object_Access_Level;
--------------------------------------
-- Original_Corresponding_Operation --
--------------------------------------
function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id
is
Typ : constant Entity_Id := Find_Dispatching_Type (S);
begin
-- If S is an inherited primitive S2 the original corresponding
-- operation of S is the original corresponding operation of S2
if Present (Alias (S))
and then Find_Dispatching_Type (Alias (S)) /= Typ
then
return Original_Corresponding_Operation (Alias (S));
-- If S overrides an inherted subprogram S2 the original corresponding
-- operation of S is the original corresponding operation of S2
elsif Is_Overriding_Operation (S)
and then Present (Overridden_Operation (S))
then
return Original_Corresponding_Operation (Overridden_Operation (S));
-- otherwise it is S itself
else
return S;
end if;
end Original_Corresponding_Operation;
-----------------------
-- Private_Component --
-----------------------
@ -11387,6 +11457,47 @@ package body Sem_Util is
end if;
end Unqualify;
-----------------------
-- Visible_Ancestors --
-----------------------
function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is
List_1 : Elist_Id;
List_2 : Elist_Id;
Elmt : Elmt_Id;
begin
pragma Assert (Is_Record_Type (Typ)
and then Is_Tagged_Type (Typ));
-- Collect all the parents and progenitors of Typ. If the full-view of
-- private parents and progenitors is available then it is used to
-- generate the list of visible ancestors; otherwise their partial
-- view is added to the resulting list.
Collect_Parents
(T => Typ,
List => List_1,
Use_Full_View => True);
Collect_Interfaces
(T => Typ,
Ifaces_List => List_2,
Exclude_Parents => True,
Use_Full_View => True);
-- Join the two lists. Avoid duplications because an interface may
-- simultaneously be parent and progenitor of a type.
Elmt := First_Elmt (List_2);
while Present (Elmt) loop
Append_Unique_Elmt (Node (Elmt), List_1);
Next_Elmt (Elmt);
end loop;
return List_1;
end Visible_Ancestors;
----------------------
-- Within_Init_Proc --
----------------------

20
gcc/ada/sem_util.ads
View File

@ -197,6 +197,13 @@ package Sem_Util is
-- of elements, and elements at the same position on these tables provide
-- information on the same interface type.
procedure Collect_Parents
(T : Entity_Id;
List : out Elist_Id;
Use_Full_View : Boolean := True);
-- Collect all the parents of Typ. Use_Full_View is used to collect them
-- using the full-view of private parents (if available).
function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id;
-- Called upon type derivation and extension. We scan the declarative part
-- in which the type appears, and collect subprograms that have one
@ -1052,6 +1059,12 @@ package Sem_Util is
-- (e.g. target of assignment, or out parameter), and to False if the
-- modification is only potential (e.g. address of entity taken).
function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id;
-- [Ada 2012: AI05-0125-1]: If S is an inherited dispatching primitive S2,
-- or overrides an inherited dispatching primitive S2, the original
-- corresponding operation of S is the original corresponding operation of
-- S2. Otherwise, it is S itself.
function Object_Access_Level (Obj : Node_Id) return Uint;
-- Return the accessibility level of the view of the object Obj.
-- For convenience, qualified expressions applied to object names
@ -1290,6 +1303,13 @@ package Sem_Util is
-- Removes any qualifications from Expr. For example, for T1'(T2'(X)), this
-- returns X. If Expr is not a qualified expression, returns Expr.
function Visible_Ancestors (Typ : Entity_Id) return Elist_Id;
-- [Ada 2012:AI-0125-1]: Collect all the visible parents and progenitors
-- of a type extension or private extension declaration. If the full-view
-- of private parents and progenitors is available then it is used to
-- generate the list of visible ancestors; otherwise their partial
-- view is added to the resulting list.
function Within_Init_Proc return Boolean;
-- Determines if Current_Scope is within an init proc