-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
with Output; use Output;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
-with Scans; use Scans;
-with Scn; use Scn;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Attr; use Sem_Attr;
with Stand; use Stand;
with Style;
with Stringt; use Stringt;
+with Table;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uname; use Uname;
with GNAT.HTable; use GNAT.HTable;
+
package body Sem_Util is
----------------------------------------
-- safely used by New_Copy_Tree, since there is no case of a recursive
-- call from the processing inside New_Copy_Tree.
- NCT_Hash_Threshhold : constant := 20;
+ NCT_Hash_Threshold : constant := 20;
-- If there are more than this number of pairs of entries in the
-- map, then Hash_Tables_Used will be set, and the hash tables will
-- be initialized and used for the searches.
-- Set to True if hash tables are in use
NCT_Table_Entries : Nat;
- -- Count entries in table to see if threshhold is reached
+ -- Count entries in table to see if threshold is reached
NCT_Hash_Table_Setup : Boolean := False;
-- Set to True if hash table contains data. We set this True if we
subtype NCT_Header_Num is Int range 0 .. 511;
-- Defines range of headers in hash tables (512 headers)
+ ----------------------------------
+ -- Order Dependence (AI05-0144) --
+ ----------------------------------
+
+ -- Each actual in a call is entered into the table below. A flag indicates
+ -- whether the corresponding formal is OUT or IN OUT. Each top-level call
+ -- (procedure call, condition, assignment) examines all the actuals for a
+ -- possible order dependence. The table is reset after each such check.
+ -- The actuals to be checked in a call to Check_Order_Dependence are at
+ -- positions 1 .. Last.
+
+ type Actual_Name is record
+ Act : Node_Id;
+ Is_Writable : Boolean;
+ end record;
+
+ package Actuals_In_Call is new Table.Table (
+ Table_Component_Type => Actual_Name,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => 10,
+ Table_Increment => 100,
+ Table_Name => "Actuals");
+
-----------------------
-- Local Subprograms --
-----------------------
Analyze (N);
end Add_Global_Declaration;
+ -----------------
+ -- Addressable --
+ -----------------
+
+ -- For now, just 8/16/32/64. but analyze later if AAMP is special???
+
+ function Addressable (V : Uint) return Boolean is
+ begin
+ return V = Uint_8 or else
+ V = Uint_16 or else
+ V = Uint_32 or else
+ V = Uint_64;
+ end Addressable;
+
+ function Addressable (V : Int) return Boolean is
+ begin
+ return V = 8 or else
+ V = 16 or else
+ V = 32 or else
+ V = 64;
+ end Addressable;
+
-----------------------
-- Alignment_In_Bits --
-----------------------
end if;
end Apply_Compile_Time_Constraint_Error;
+ --------------------------------
+ -- Bad_Predicated_Subtype_Use --
+ --------------------------------
+
+ procedure Bad_Predicated_Subtype_Use
+ (Msg : String;
+ N : Node_Id;
+ Typ : Entity_Id)
+ is
+ begin
+ if Has_Predicates (Typ) then
+ if Is_Generic_Actual_Type (Typ) then
+ Error_Msg_FE (Msg & '?', N, Typ);
+ Error_Msg_F ("\Program_Error will be raised at run time?", N);
+ Insert_Action (N,
+ Make_Raise_Program_Error (Sloc (N),
+ Reason => PE_Bad_Predicated_Generic_Type));
+
+ else
+ Error_Msg_FE (Msg, N, Typ);
+ end if;
+ end if;
+ end Bad_Predicated_Subtype_Use;
+
--------------------------
-- Build_Actual_Subtype --
--------------------------
end if;
end Check_Nested_Access;
+ ----------------------------
+ -- Check_Order_Dependence --
+ ----------------------------
+
+ procedure Check_Order_Dependence is
+ Act1 : Node_Id;
+ Act2 : Node_Id;
+
+ begin
+ if Ada_Version < Ada_2012 then
+ return;
+ end if;
+
+ -- Ada 2012 AI04-0144-2: Dangerous order dependence. Actuals in nested
+ -- calls within a construct have been collected. If one of them is
+ -- writable and overlaps with another one, evaluation of the enclosing
+ -- construct is nondeterministic. This is illegal in Ada 2012, but is
+ -- treated as a warning for now.
+
+ for J in 1 .. Actuals_In_Call.Last loop
+ if Actuals_In_Call.Table (J).Is_Writable then
+ Act1 := Actuals_In_Call.Table (J).Act;
+
+ if Nkind (Act1) = N_Attribute_Reference then
+ Act1 := Prefix (Act1);
+ end if;
+
+ for K in 1 .. Actuals_In_Call.Last loop
+ if K /= J then
+ Act2 := Actuals_In_Call.Table (K).Act;
+
+ if Nkind (Act2) = N_Attribute_Reference then
+ Act2 := Prefix (Act2);
+ end if;
+
+ if Actuals_In_Call.Table (K).Is_Writable
+ and then K < J
+ then
+ -- Already checked
+
+ null;
+
+ elsif Denotes_Same_Object (Act1, Act2)
+ and then Parent (Act1) /= Parent (Act2)
+ then
+ Error_Msg_N
+ ("result may differ if evaluated "
+ & "after other actual in expression?", Act1);
+ end if;
+ end if;
+ end loop;
+ end if;
+ end loop;
+
+ -- Remove checked actuals from table
+
+ Actuals_In_Call.Set_Last (0);
+ end Check_Order_Dependence;
+
------------------------------------------
-- Check_Potentially_Blocking_Operation --
------------------------------------------
procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
S : Entity_Id;
+
begin
-- N is one of the potentially blocking operations listed in 9.5.1(8).
-- When pragma Detect_Blocking is active, the run time will raise
if Is_Protected_Type (S) then
Error_Msg_N
("potentially blocking operation in protected operation?", N);
-
return;
end if;
function Search_Tag (Iface : Entity_Id) return Entity_Id is
ADT : Elmt_Id;
-
begin
- ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
+ if not Is_CPP_Class (T) then
+ ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
+ else
+ ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
+ end if;
+
while Present (ADT)
- and then Ekind (Node (ADT)) = E_Constant
+ and then Is_Tag (Node (ADT))
and then Related_Type (Node (ADT)) /= Iface
loop
- -- Skip the secondary dispatch tables of Iface
+ -- Skip secondary dispatch table referencing thunks to user
+ -- defined primitives covered by this interface.
+ pragma Assert (Has_Suffix (Node (ADT), 'P'));
Next_Elmt (ADT);
- Next_Elmt (ADT);
- Next_Elmt (ADT);
- Next_Elmt (ADT);
+
+ -- Skip secondary dispatch tables of Ada types
+
+ if not Is_CPP_Class (T) then
+
+ -- Skip secondary dispatch table referencing thunks to
+ -- predefined primitives.
+
+ pragma Assert (Has_Suffix (Node (ADT), 'Y'));
+ Next_Elmt (ADT);
+
+ -- Skip secondary dispatch table referencing user-defined
+ -- primitives covered by this interface.
+
+ pragma Assert (Has_Suffix (Node (ADT), 'D'));
+ Next_Elmt (ADT);
+
+ -- Skip secondary dispatch table referencing predefined
+ -- primitives.
+
+ pragma Assert (Has_Suffix (Node (ADT), 'Z'));
+ Next_Elmt (ADT);
+ end if;
end loop;
- pragma Assert (Ekind (Node (ADT)) = E_Constant);
+ pragma Assert (Is_Tag (Node (ADT)));
return Node (ADT);
end Search_Tag;
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 --
----------------------------------
Formal_Derived : Boolean := False;
Id : Entity_Id;
+ function Match (E : Entity_Id) return Boolean;
+ -- True if E's base type is B_Type, or E is of an anonymous access type
+ -- and the base type of its designated type is B_Type.
+
+ -----------
+ -- Match --
+ -----------
+
+ function Match (E : Entity_Id) return Boolean is
+ Etyp : Entity_Id := Etype (E);
+
+ begin
+ if Ekind (Etyp) = E_Anonymous_Access_Type then
+ Etyp := Designated_Type (Etyp);
+ end if;
+
+ return Base_Type (Etyp) = B_Type;
+ end Match;
+
+ -- Start of processing for Collect_Primitive_Operations
+
begin
-- For tagged types, the primitive operations are collected as they
-- are declared, and held in an explicit list which is simply returned.
then
Is_Prim := False;
- if Base_Type (Etype (Id)) = B_Type then
+ if Match (Id) then
Is_Prim := True;
+
else
Formal := First_Formal (Id);
while Present (Formal) loop
- if Base_Type (Etype (Formal)) = B_Type then
- Is_Prim := True;
- exit;
-
- elsif Ekind (Etype (Formal)) = E_Anonymous_Access_Type
- and then Base_Type
- (Designated_Type (Etype (Formal))) = B_Type
- then
+ if Match (Formal) then
Is_Prim := True;
exit;
end if;
if Chars (Id) = Name_Op_Eq
and then Is_Dispatching_Operation (Id)
and then Present (Alias (Id))
- and then Is_Overriding_Operation (Alias (Id))
+ and then Present (Overridden_Operation (Alias (Id)))
and then Base_Type (Etype (First_Entity (Id))) =
Base_Type (Etype (First_Entity (Alias (Id))))
then
-- appear in the target-specific extension to System.
if No (Id)
- and then Chars (B_Scope) = Name_System
- and then Scope (B_Scope) = Standard_Standard
+ and then B_Scope = RTU_Entity (System)
and then Present_System_Aux
then
B_Scope := System_Aux_Id;
-------------------------
function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
+ Obj1 : Node_Id := A1;
+ Obj2 : Node_Id := A2;
+
+ procedure Check_Renaming (Obj : in out Node_Id);
+ -- If an object is a renaming, examine renamed object. If it is a
+ -- dereference of a variable, or an indexed expression with non-constant
+ -- indexes, no overlap check can be reported.
+
+ --------------------
+ -- Check_Renaming --
+ --------------------
+
+ procedure Check_Renaming (Obj : in out Node_Id) is
+ begin
+ if Is_Entity_Name (Obj)
+ and then Present (Renamed_Entity (Entity (Obj)))
+ then
+ Obj := Renamed_Entity (Entity (Obj));
+ if Nkind (Obj) = N_Explicit_Dereference
+ and then Is_Variable (Prefix (Obj))
+ then
+ Obj := Empty;
+
+ elsif Nkind (Obj) = N_Indexed_Component then
+ declare
+ Indx : Node_Id;
+
+ begin
+ Indx := First (Expressions (Obj));
+ while Present (Indx) loop
+ if not Is_OK_Static_Expression (Indx) then
+ Obj := Empty;
+ exit;
+ end if;
+
+ Next_Index (Indx);
+ end loop;
+ end;
+ end if;
+ end if;
+ end Check_Renaming;
+
+ -- Start of processing for Denotes_Same_Object
+
begin
+ Check_Renaming (Obj1);
+ Check_Renaming (Obj2);
+
+ if No (Obj1)
+ or else No (Obj2)
+ then
+ return False;
+ end if;
+
-- If we have entity names, then must be same entity
- if Is_Entity_Name (A1) then
- if Is_Entity_Name (A2) then
- return Entity (A1) = Entity (A2);
+ if Is_Entity_Name (Obj1) then
+ if Is_Entity_Name (Obj2) then
+ return Entity (Obj1) = Entity (Obj2);
else
return False;
end if;
-- No match if not same node kind
- elsif Nkind (A1) /= Nkind (A2) then
+ elsif Nkind (Obj1) /= Nkind (Obj2) then
return False;
-- For selected components, must have same prefix and selector
- elsif Nkind (A1) = N_Selected_Component then
- return Denotes_Same_Object (Prefix (A1), Prefix (A2))
+ elsif Nkind (Obj1) = N_Selected_Component then
+ return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
and then
- Entity (Selector_Name (A1)) = Entity (Selector_Name (A2));
+ Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2));
-- For explicit dereferences, prefixes must be same
- elsif Nkind (A1) = N_Explicit_Dereference then
- return Denotes_Same_Object (Prefix (A1), Prefix (A2));
+ elsif Nkind (Obj1) = N_Explicit_Dereference then
+ return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2));
-- For indexed components, prefixes and all subscripts must be the same
- elsif Nkind (A1) = N_Indexed_Component then
- if Denotes_Same_Object (Prefix (A1), Prefix (A2)) then
+ elsif Nkind (Obj1) = N_Indexed_Component then
+ if Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then
declare
Indx1 : Node_Id;
Indx2 : Node_Id;
begin
- Indx1 := First (Expressions (A1));
- Indx2 := First (Expressions (A2));
+ Indx1 := First (Expressions (Obj1));
+ Indx2 := First (Expressions (Obj2));
while Present (Indx1) loop
- -- Shouldn't we be checking that values are the same???
+ -- Indexes must denote the same static value or same object
+
+ if Is_OK_Static_Expression (Indx1) then
+ if not Is_OK_Static_Expression (Indx2) then
+ return False;
+
+ elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then
+ return False;
+ end if;
- if not Denotes_Same_Object (Indx1, Indx2) then
+ elsif not Denotes_Same_Object (Indx1, Indx2) then
return False;
end if;
-- For slices, prefixes must match and bounds must match
- elsif Nkind (A1) = N_Slice
- and then Denotes_Same_Object (Prefix (A1), Prefix (A2))
+ elsif Nkind (Obj1) = N_Slice
+ and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
then
declare
Lo1, Lo2, Hi1, Hi2 : Node_Id;
begin
- Get_Index_Bounds (Etype (A1), Lo1, Hi1);
- Get_Index_Bounds (Etype (A2), Lo2, Hi2);
+ Get_Index_Bounds (Etype (Obj1), Lo1, Hi1);
+ Get_Index_Bounds (Etype (Obj2), Lo2, Hi2);
-- Check whether bounds are statically identical. There is no
-- attempt to detect partial overlap of slices.
- -- What about an array and a slice of an array???
-
return Denotes_Same_Object (Lo1, Lo2)
and then Denotes_Same_Object (Hi1, Hi2);
end;
- -- Literals will appear as indices. Isn't this where we should check
+ -- Literals will appear as indexes. Isn't this where we should check
-- Known_At_Compile_Time at least if we are generating warnings ???
- elsif Nkind (A1) = N_Integer_Literal then
- return Intval (A1) = Intval (A2);
+ elsif Nkind (Obj1) = N_Integer_Literal then
+ return Intval (Obj1) = Intval (Obj2);
else
return False;
begin
if Is_Entity_Name (A1) then
- if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) then
+ if Nkind_In (A2, N_Selected_Component, N_Indexed_Component)
+ and then not Is_Access_Type (Etype (A1))
+ then
return Denotes_Same_Object (A1, Prefix (A2))
or else Denotes_Same_Prefix (A1, Prefix (A2));
else
end if;
end Designate_Same_Unit;
+ --------------------------
+ -- Enclosing_CPP_Parent --
+ --------------------------
+
+ function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is
+ Parent_Typ : Entity_Id := Typ;
+
+ begin
+ while not Is_CPP_Class (Parent_Typ)
+ and then Etype (Parent_Typ) /= Parent_Typ
+ loop
+ Parent_Typ := Etype (Parent_Typ);
+
+ if Is_Private_Type (Parent_Typ) then
+ Parent_Typ := Full_View (Base_Type (Parent_Typ));
+ end if;
+ end loop;
+
+ pragma Assert (Is_CPP_Class (Parent_Typ));
+ return Parent_Typ;
+ end Enclosing_CPP_Parent;
+
----------------------------
-- Enclosing_Generic_Body --
----------------------------
elsif Ekind (Dynamic_Scope) = E_Task_Type then
return Get_Task_Body_Procedure (Dynamic_Scope);
+ elsif Ekind (Dynamic_Scope) = E_Limited_Private_Type
+ and then Present (Full_View (Dynamic_Scope))
+ and then Ekind (Full_View (Dynamic_Scope)) = E_Task_Type
+ then
+ return Get_Task_Body_Procedure (Full_View (Dynamic_Scope));
+
-- No body is generated if the protected operation is eliminated
elsif Convention (Dynamic_Scope) = Convention_Protected
Set_Scope (Def_Id, Current_Scope);
return;
- -- Analogous to privals, the discriminal generated for an entry
- -- index parameter acts as a weak declaration. Perform minimal
- -- decoration to avoid bogus errors.
+ -- Analogous to privals, the discriminal generated for an entry index
+ -- parameter acts as a weak declaration. Perform minimal decoration
+ -- to avoid bogus errors.
elsif Is_Discriminal (Def_Id)
and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter
Set_Scope (Def_Id, Current_Scope);
return;
- -- In the body or private part of an instance, a type extension
- -- may introduce a component with the same name as that of an
- -- actual. The legality rule is not enforced, but the semantics
- -- of the full type with two components of the same name are not
- -- clear at this point ???
+ -- In the body or private part of an instance, a type extension may
+ -- introduce a component with the same name as that of an actual. The
+ -- legality rule is not enforced, but the semantics of the full type
+ -- with two components of same name are not clear at this point???
elsif In_Instance_Not_Visible then
null;
then
null;
- -- Conversely, with front-end inlining we may compile the parent
- -- body first, and a child unit subsequently. The context is now
- -- the parent spec, and body entities are not visible.
+ -- Conversely, with front-end inlining we may compile the parent body
+ -- first, and a child unit subsequently. The context is now the
+ -- parent spec, and body entities are not visible.
elsif Is_Child_Unit (Def_Id)
and then Is_Package_Body_Entity (E)
Error_Msg_Sloc := Sloc (E);
-- If the previous declaration is an incomplete type declaration
- -- this may be an attempt to complete it with a private type.
- -- The following avoids confusing cascaded errors.
+ -- this may be an attempt to complete it with a private type. The
+ -- following avoids confusing cascaded errors.
if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
Error_Msg_N ("& conflicts with declaration#", E);
return;
- -- If the name of the unit appears in its own context clause,
- -- a dummy package with the name has already been created, and
- -- the error emitted. Try to continue quietly.
+ -- If the name of the unit appears in its own context clause, a
+ -- dummy package with the name has already been created, and the
+ -- error emitted. Try to continue quietly.
elsif Error_Posted (E)
and then Sloc (E) = No_Location
Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
end if;
- -- If entity is in standard, then we are in trouble, because
- -- it means that we have a library package with a duplicated
- -- name. That's hard to recover from, so abort!
+ -- If entity is in standard, then we are in trouble, because it
+ -- means that we have a library package with a duplicated name.
+ -- That's hard to recover from, so abort!
if S = Standard_Standard then
raise Unrecoverable_Error;
end if;
end if;
- -- If we fall through, declaration is OK , or OK enough to continue
+ -- If we fall through, declaration is OK, at least OK enough to continue
- -- If Def_Id is a discriminant or a record component we are in the
- -- midst of inheriting components in a derived record definition.
- -- Preserve their Ekind and Etype.
+ -- If Def_Id is a discriminant or a record component we are in the midst
+ -- of inheriting components in a derived record definition. Preserve
+ -- their Ekind and Etype.
if Ekind_In (Def_Id, E_Discriminant, E_Component) then
null;
- -- If a type is already set, leave it alone (happens whey a type
- -- declaration is reanalyzed following a call to the optimizer)
+ -- If a type is already set, leave it alone (happens when a type
+ -- declaration is reanalyzed following a call to the optimizer).
elsif Present (Etype (Def_Id)) then
null;
and then In_Extended_Main_Source_Unit (Def_Id)
- -- Finally, the hidden entity must be either immediately visible
- -- or use visible (from a used package)
+ -- Finally, the hidden entity must be either immediately visible or
+ -- use visible (i.e. from a used package).
and then
(Is_Immediately_Visible (C)
end if;
end First_Actual;
- -------------------------
- -- Full_Qualified_Name --
- -------------------------
-
- function Full_Qualified_Name (E : Entity_Id) return String_Id is
- Res : String_Id;
- pragma Warnings (Off, Res);
-
- function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id;
- -- Compute recursively the qualified name without NUL at the end
-
- ----------------------------------
- -- Internal_Full_Qualified_Name --
- ----------------------------------
-
- function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id is
- Ent : Entity_Id := E;
- Parent_Name : String_Id := No_String;
-
- begin
- -- Deals properly with child units
-
- if Nkind (Ent) = N_Defining_Program_Unit_Name then
- Ent := Defining_Identifier (Ent);
- end if;
-
- -- Compute qualification recursively (only "Standard" has no scope)
-
- if Present (Scope (Scope (Ent))) then
- Parent_Name := Internal_Full_Qualified_Name (Scope (Ent));
- end if;
-
- -- Every entity should have a name except some expanded blocks
- -- don't bother about those.
-
- if Chars (Ent) = No_Name then
- return Parent_Name;
- end if;
-
- -- Add a period between Name and qualification
-
- if Parent_Name /= No_String then
- Start_String (Parent_Name);
- Store_String_Char (Get_Char_Code ('.'));
-
- else
- Start_String;
- end if;
-
- -- Generates the entity name in upper case
-
- Get_Decoded_Name_String (Chars (Ent));
- Set_All_Upper_Case;
- Store_String_Chars (Name_Buffer (1 .. Name_Len));
- return End_String;
- end Internal_Full_Qualified_Name;
-
- -- Start of processing for Full_Qualified_Name
-
- begin
- Res := Internal_Full_Qualified_Name (E);
- Store_String_Char (Get_Char_Code (ASCII.NUL));
- return End_String;
- end Full_Qualified_Name;
-
-----------------------
-- Gather_Components --
-----------------------
function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
BT : constant Entity_Id := Base_Type (T);
- Comp : Entity_Id;
P : Elmt_Id;
begin
if Is_Controlled (BT) then
-
- -- For derived types, check immediate ancestor, excluding
- -- Controlled itself.
-
- if Is_Derived_Type (BT)
- and then not In_Predefined_Unit (Etype (BT))
- and then Has_Overriding_Initialize (Etype (BT))
- then
- return True;
+ if Is_RTU (Scope (BT), Ada_Finalization) then
+ return False;
elsif Present (Primitive_Operations (BT)) then
P := First_Elmt (Primitive_Operations (BT));
while Present (P) loop
- if Chars (Node (P)) = Name_Initialize
- and then Comes_From_Source (Node (P))
- then
- return True;
- end if;
+ declare
+ Init : constant Entity_Id := Node (P);
+ Formal : constant Entity_Id := First_Formal (Init);
+ begin
+ if Ekind (Init) = E_Procedure
+ and then Chars (Init) = Name_Initialize
+ and then Comes_From_Source (Init)
+ and then Present (Formal)
+ and then Etype (Formal) = BT
+ and then No (Next_Formal (Formal))
+ and then (Ada_Version < Ada_2012
+ or else not Null_Present (Parent (Init)))
+ then
+ return True;
+ end if;
+ end;
Next_Elmt (P);
end loop;
end if;
- return False;
+ -- Here if type itself does not have a non-null Initialize operation:
+ -- check immediate ancestor.
- elsif Has_Controlled_Component (BT) then
- Comp := First_Component (BT);
- while Present (Comp) loop
- if Has_Overriding_Initialize (Etype (Comp)) then
- return True;
- end if;
-
- Next_Component (Comp);
- end loop;
-
- return False;
-
- else
- return False;
+ if Is_Derived_Type (BT)
+ and then Has_Overriding_Initialize (Etype (BT))
+ then
+ return True;
+ end if;
end if;
+
+ return False;
end Has_Overriding_Initialize;
--------------------------------------
-- We are interested only in components and discriminants
- if Ekind_In (Ent, E_Component, E_Discriminant) then
+ Exp := Empty;
- -- Get default expression if any. If there is no declaration
- -- node, it means we have an internal entity. The parent and
- -- tag fields are examples of such entities. For these cases,
- -- we just test the type of the entity.
+ case Ekind (Ent) is
+ when E_Component =>
- if Present (Declaration_Node (Ent)) then
- Exp := Expression (Declaration_Node (Ent));
- else
- Exp := Empty;
- end if;
+ -- Get default expression if any. If there is no declaration
+ -- node, it means we have an internal entity. The parent and
+ -- tag fields are examples of such entities. For such cases,
+ -- we just test the type of the entity.
- -- A component has PI if it has no default expression and the
- -- component type has PI.
-
- if No (Exp) then
- if not Has_Preelaborable_Initialization (Etype (Ent)) then
- Has_PE := False;
- exit;
+ if Present (Declaration_Node (Ent)) then
+ Exp := Expression (Declaration_Node (Ent));
end if;
- -- Require the default expression to be preelaborable
+ when E_Discriminant =>
+
+ -- Note: for a renamed discriminant, the Declaration_Node
+ -- may point to the one from the ancestor, and have a
+ -- different expression, so use the proper attribute to
+ -- retrieve the expression from the derived constraint.
+
+ Exp := Discriminant_Default_Value (Ent);
- elsif not Is_Preelaborable_Expression (Exp) then
+ when others =>
+ goto Check_Next_Entity;
+ end case;
+
+ -- A component has PI if it has no default expression and the
+ -- component type has PI.
+
+ if No (Exp) then
+ if not Has_Preelaborable_Initialization (Etype (Ent)) then
Has_PE := False;
exit;
end if;
+
+ -- Require the default expression to be preelaborable
+
+ elsif not Is_Preelaborable_Expression (Exp) then
+ Has_PE := False;
+ exit;
end if;
+ <<Check_Next_Entity>>
Next_Entity (Ent);
end loop;
end Check_Components;
end if;
end Has_Stream;
+ ----------------
+ -- Has_Suffix --
+ ----------------
+
+ function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
+ begin
+ Get_Name_String (Chars (E));
+ return Name_Buffer (Name_Len) = Suffix;
+ end Has_Suffix;
+
--------------------------
-- Has_Tagged_Component --
--------------------------
end if;
end Has_Tagged_Component;
+ -------------------------
+ -- Implementation_Kind --
+ -------------------------
+
+ function Implementation_Kind (Subp : Entity_Id) return Name_Id is
+ Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
+ begin
+ pragma Assert (Present (Impl_Prag));
+ return
+ Chars (Expression (Last (Pragma_Argument_Associations (Impl_Prag))));
+ end Implementation_Kind;
+
--------------------------
-- Implements_Interface --
--------------------------
begin
Save_Interps (N, New_Prefix);
- Rewrite (N, Make_Explicit_Dereference (Sloc (N), Prefix => New_Prefix));
+ Rewrite (N,
+ Make_Explicit_Dereference (Sloc (Parent (N)),
+ Prefix => New_Prefix));
Set_Etype (N, Designated_Type (Etype (New_Prefix)));
if Is_Entity_Name (New_Prefix) then
Ent := Entity (New_Prefix);
+ Pref := New_Prefix;
-- For a retrieval of a subcomponent of some composite object,
-- retrieve the ultimate entity if there is one.
end if;
end if;
+ -- Place the reference on the entity node
+
if Present (Ent) then
- Generate_Reference (Ent, New_Prefix);
+ Generate_Reference (Ent, Pref);
end if;
end if;
end Insert_Explicit_Dereference;
and then Comes_From_Source (Decl)
- -- The constant is not completed. A full object declaration
- -- or a pragma Import complete a deferred constant.
+ -- The constant is not completed. A full object declaration or a
+ -- pragma Import complete a deferred constant.
and then not Has_Completion (Defining_Identifier (Decl))
then
end loop;
end Inspect_Deferred_Constant_Completion;
- -------------------
- -- Is_AAMP_Float --
- -------------------
-
- function Is_AAMP_Float (E : Entity_Id) return Boolean is
- pragma Assert (Is_Type (E));
- begin
- return AAMP_On_Target
- and then Is_Floating_Point_Type (E)
- and then E = Base_Type (E);
- end Is_AAMP_Float;
-
-----------------------------
-- Is_Actual_Out_Parameter --
-----------------------------
Call : Node_Id;
begin
Find_Actual (N, Formal, Call);
- return Present (Formal)
- and then Ekind (Formal) = E_Out_Parameter;
+ return Present (Formal) and then Ekind (Formal) = E_Out_Parameter;
end Is_Actual_Out_Parameter;
-------------------------
begin
-- Predicate is not relevant to subprograms
- if Is_Entity_Name (N)
- and then Is_Overloadable (Entity (N))
- then
+ if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then
return False;
elsif Is_Atomic (Etype (N))
----------------------------------------------
function Is_Dependent_Component_Of_Mutable_Object
- (Object : Node_Id) return Boolean
+ (Object : Node_Id) return Boolean
is
P : Node_Id;
Prefix_Type : Entity_Id;
P_Aliased := True;
end if;
- -- A discriminant check on a selected component may be
- -- expanded into a dereference when removing side-effects.
- -- Recover the original node and its type, which may be
- -- unconstrained.
+ -- A discriminant check on a selected component may be expanded
+ -- into a dereference when removing side-effects. Recover the
+ -- original node and its type, which may be unconstrained.
elsif Nkind (P) = N_Explicit_Dereference
and then not (Comes_From_Source (P))
Prefix_Type := Etype (P);
else
- -- Check for prefix being an aliased component ???
+ -- Check for prefix being an aliased component???
+
null;
end if;
-- (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are
-- semantic rules -- these rules are acknowledged to need fixing).
- if Ada_Version < Ada_05 then
+ if Ada_Version < Ada_2005 then
if Is_Access_Type (Prefix_Type)
or else Nkind (P) = N_Explicit_Dereference
then
return False;
end if;
- elsif Ada_Version >= Ada_05 then
+ elsif Ada_Version >= Ada_2005 then
if Is_Access_Type (Prefix_Type) then
-- If the access type is pool-specific, and there is no
Comp :=
Original_Record_Component (Entity (Selector_Name (Object)));
- -- As per AI-0017, the renaming is illegal in a generic body,
- -- even if the subtype is indefinite.
+ -- As per AI-0017, the renaming is illegal in a generic body, even
+ -- if the subtype is indefinite.
-- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
and then (Is_Declared_Within_Variant (Comp)
or else Has_Discriminant_Dependent_Constraint (Comp))
- and then (not P_Aliased or else Ada_Version >= Ada_05)
+ and then (not P_Aliased or else Ada_Version >= Ada_2005)
then
return True;
function Is_LHS (N : Node_Id) return Boolean is
P : constant Node_Id := Parent (N);
+
begin
- return Nkind (P) = N_Assignment_Statement
- and then Name (P) = N;
+ if Nkind (P) = N_Assignment_Statement then
+ return Name (P) = N;
+
+ elsif
+ Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice)
+ then
+ return N = Prefix (P) and then Is_LHS (P);
+
+ else
+ return False;
+ end if;
end Is_LHS;
----------------------------
-- the corresponding procedure has been created, and which therefore do
-- not have an assigned scope.
- if Ekind (E) in Formal_Kind then
+ if Is_Formal (E) then
return False;
end if;
-- Is_Partially_Initialized_Type --
-----------------------------------
- function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean is
+ function Is_Partially_Initialized_Type
+ (Typ : Entity_Id;
+ Include_Implicit : Boolean := True) return Boolean
+ is
begin
if Is_Scalar_Type (Typ) then
return False;
elsif Is_Access_Type (Typ) then
- return True;
+ return Include_Implicit;
elsif Is_Array_Type (Typ) then
-- If component type is partially initialized, so is array type
- if Is_Partially_Initialized_Type (Component_Type (Typ)) then
+ if Is_Partially_Initialized_Type
+ (Component_Type (Typ), Include_Implicit)
+ then
return True;
-- Otherwise we are only partially initialized if we are fully
elsif Is_Record_Type (Typ) then
- -- A discriminated type is always partially initialized
+ -- A discriminated type is always partially initialized if in
+ -- all mode
- if Has_Discriminants (Typ) then
+ if Has_Discriminants (Typ) and then Include_Implicit then
return True;
-- A tagged type is always partially initialized
-- If a component is of a type which is itself partially
-- initialized, then the enclosing record type is also.
- elsif Is_Partially_Initialized_Type (Etype (Ent)) then
+ elsif Is_Partially_Initialized_Type
+ (Etype (Ent), Include_Implicit)
+ then
return True;
end if;
end if;
if No (U) then
return True;
else
- return Is_Partially_Initialized_Type (U);
+ return Is_Partially_Initialized_Type (U, Include_Implicit);
end if;
end;
-- because they denote entities that are not necessarily visible.
-- Neither of them can apply to a protected type.
- return Ada_Version >= Ada_05
+ return Ada_Version >= Ada_2005
and then Is_Entity_Name (N)
and then Present (Entity (N))
and then Is_Protected_Type (Entity (N))
function Is_VMS_Operator (Op : Entity_Id) return Boolean is
begin
+ -- The VMS operators are declared in a child of System that is loaded
+ -- through pragma Extend_System. In some rare cases a program is run
+ -- with this extension but without indicating that the target is VMS.
+
return Ekind (Op) = E_Function
and then Is_Intrinsic_Subprogram (Op)
- and then Chars (Scope (Scope (Op))) = Name_System
- and then OpenVMS_On_Target;
+ and then
+ ((Present_System_Aux
+ and then Scope (Op) = System_Aux_Id)
+ or else
+ (True_VMS_Target
+ and then Scope (Scope (Op)) = RTU_Entity (System)));
end Is_VMS_Operator;
-----------------
-- expansion.
function In_Protected_Function (E : Entity_Id) return Boolean;
- -- Within a protected function, the private components of the
- -- enclosing protected type are constants. A function nested within
- -- a (protected) procedure is not itself protected.
+ -- Within a protected function, the private components of the enclosing
+ -- protected type are constants. A function nested within a (protected)
+ -- procedure is not itself protected.
function Is_Variable_Prefix (P : Node_Id) return Boolean;
- -- Prefixes can involve implicit dereferences, in which case we
- -- must test for the case of a reference of a constant access
- -- type, which can never be a variable.
+ -- Prefixes can involve implicit dereferences, in which case we must
+ -- test for the case of a reference of a constant access type, which can
+ -- can never be a variable.
---------------------------
-- In_Protected_Function --
else
S := Current_Scope;
while Present (S) and then S /= Prot loop
- if Ekind (S) = E_Function
- and then Scope (S) = Prot
- then
+ if Ekind (S) = E_Function and then Scope (S) = Prot then
return True;
end if;
if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
return True;
- -- Normally we go to the original node, but there is one exception
- -- where we use the rewritten node, namely when it is an explicit
- -- dereference. The generated code may rewrite a prefix which is an
- -- access type with an explicit dereference. The dereference is a
- -- variable, even though the original node may not be (since it could
- -- be a constant of the access type).
+ -- Normally we go to the original node, but there is one exception where
+ -- we use the rewritten node, namely when it is an explicit dereference.
+ -- The generated code may rewrite a prefix which is an access type with
+ -- an explicit dereference. The dereference is a variable, even though
+ -- the original node may not be (since it could be a constant of the
+ -- access type).
- -- In Ada 2005 we have a further case to consider: the prefix may be
- -- a function call given in prefix notation. The original node appears
- -- to be a selected component, but we need to examine the call.
+ -- In Ada 2005 we have a further case to consider: the prefix may be a
+ -- function call given in prefix notation. The original node appears to
+ -- be a selected component, but we need to examine the call.
elsif Nkind (N) = N_Explicit_Dereference
and then Nkind (Orig_Node) /= N_Explicit_Dereference
when N_Explicit_Dereference =>
return False;
- -- Function call arguments are never lvalues
-
- when N_Function_Call =>
- return False;
-
- -- Positional parameter for procedure, entry, or accept call
+ -- Positional parameter for subprogram, entry, or accept call.
+ -- In older versions of Ada function call arguments are never
+ -- lvalues. In Ada 2012 functions can have in-out parameters.
- when N_Procedure_Call_Statement |
+ when N_Function_Call |
+ N_Procedure_Call_Statement |
N_Entry_Call_Statement |
N_Accept_Statement
=>
+ if Nkind (P) = N_Function_Call
+ and then Ada_Version < Ada_2012
+ then
+ return False;
+ end if;
+
+ -- The following mechanism is clumsy and fragile. A single
+ -- flag set in Resolve_Actuals would be preferable ???
+
declare
Proc : Entity_Id;
Form : Entity_Id;
if Nkind (N) = N_Allocator then
if Is_Dynamic then
Set_Is_Dynamic_Coextension (N);
+
+ -- If the allocator expression is potentially dynamic, it may
+ -- be expanded out of order and require dynamic allocation
+ -- anyway, so we treat the coextension itself as dynamic.
+ -- Potential optimization ???
+
+ elsif Nkind (Expression (N)) = N_Qualified_Expression
+ and then Nkind (Expression (Expression (N))) = N_Op_Concat
+ then
+ Set_Is_Dynamic_Coextension (N);
+
else
Set_Is_Static_Coextension (N);
end if;
Formal : Entity_Id;
begin
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Present (First_Formal (E))
then
Formal := Next_Formal (First_Formal (E));
-- Itype references within the copied tree.
-- The following hash tables are used if the Map supplied has more
- -- than hash threshhold entries to speed up access to the map. If
+ -- than hash threshold entries to speed up access to the map. If
-- there are fewer entries, then the map is searched sequentially
-- (because setting up a hash table for only a few entries takes
-- more time than it saves.
else
NCT_Table_Entries := NCT_Table_Entries + 1;
- if NCT_Table_Entries > NCT_Hash_Threshhold then
+ if NCT_Table_Entries > NCT_Hash_Threshold then
Build_NCT_Hash_Tables;
end if;
end if;
Next_Elmt (Elmt);
end loop;
- if NCT_Table_Entries > NCT_Hash_Threshhold then
+ if NCT_Table_Entries > NCT_Hash_Threshold then
Build_NCT_Hash_Tables;
else
NCT_Hash_Tables_Used := False;
if Comes_From_Source (Exp)
or else Modification_Comes_From_Source
then
- if Has_Pragma_Unmodified (Ent) then
+ -- Give warning if pragma unmodified given and we are
+ -- sure this is a modification.
+
+ if Has_Pragma_Unmodified (Ent) and then Sure then
Error_Msg_NE ("?pragma Unmodified given for &!", N, Ent);
end if;
if Modification_Comes_From_Source then
Generate_Reference (Ent, Exp, 'm');
+
+ -- If the target of the assignment is the bound variable
+ -- in an iterator, indicate that the corresponding array
+ -- or container is also modified.
+
+ if Ada_Version >= Ada_2012
+ and then
+ Nkind (Parent (Ent)) = N_Iterator_Specification
+ then
+ declare
+ Domain : constant Node_Id := Name (Parent (Ent));
+
+ begin
+ -- TBD : in the full version of the construct, the
+ -- domain of iteration can be given by an expression.
+
+ if Is_Entity_Name (Domain) then
+ Generate_Reference (Entity (Domain), Exp, 'm');
+ Set_Is_True_Constant (Entity (Domain), False);
+ Set_Never_Set_In_Source (Entity (Domain), False);
+ end if;
+ end;
+ end if;
end if;
Check_Nested_Access (Ent);
-- version of the code causes regressions in several tests that are
-- compiled with -gnat95. ???)
- if Ada_Version < Ada_05 then
+ if Ada_Version < Ada_2005 then
if Is_Entity_Name (Name (Obj)) then
return Subprogram_Access_Level (Entity (Name (Obj)));
else
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 inherited subprogram S2 the original corresponding
+ -- operation of S is the original corresponding operation of S2
+
+ elsif 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 --
-----------------------
Set_Sloc (Endl, Loc);
end Process_End_Label;
- ------------------
- -- Real_Convert --
- ------------------
-
- -- We do the conversion to get the value of the real string by using
- -- the scanner, see Sinput for details on use of the internal source
- -- buffer for scanning internal strings.
-
- function Real_Convert (S : String) return Node_Id is
- Save_Src : constant Source_Buffer_Ptr := Source;
- Negative : Boolean;
-
- begin
- Source := Internal_Source_Ptr;
- Scan_Ptr := 1;
-
- for J in S'Range loop
- Source (Source_Ptr (J)) := S (J);
- end loop;
-
- Source (S'Length + 1) := EOF;
-
- if Source (Scan_Ptr) = '-' then
- Negative := True;
- Scan_Ptr := Scan_Ptr + 1;
- else
- Negative := False;
- end if;
-
- Scan;
-
- if Negative then
- Set_Realval (Token_Node, UR_Negate (Realval (Token_Node)));
- end if;
-
- Source := Save_Src;
- return Token_Node;
- end Real_Convert;
-
------------------------------------
-- References_Generic_Formal_Type --
------------------------------------
if Requires_Transient_Scope (Component_Type (Typ)) then
return True;
- -- Otherwise, we only need a transient scope if the size is not
- -- known at compile time.
+ -- Otherwise, we only need a transient scope if the size depends on
+ -- the value of one or more discriminants.
else
- return not Size_Known_At_Compile_Time (Typ);
+ return Size_Depends_On_Discriminant (Typ);
end if;
-- All other cases do not require a transient scope
begin
-- First case, both are entities with same entity
- if K1 in N_Has_Entity
- and then K2 in N_Has_Entity
- and then Present (Entity (N1))
- and then Present (Entity (N2))
- and then (Ekind (Entity (N1)) = E_Variable
- or else
- Ekind (Entity (N1)) = E_Constant)
- and then Entity (N1) = Entity (N2)
- then
- return True;
+ if K1 in N_Has_Entity and then K2 in N_Has_Entity then
+ declare
+ EN1 : constant Entity_Id := Entity (N1);
+ EN2 : constant Entity_Id := Entity (N2);
+ begin
+ if Present (EN1) and then Present (EN2)
+ and then (Ekind_In (EN1, E_Variable, E_Constant)
+ or else Is_Formal (EN1))
+ and then EN1 = EN2
+ then
+ return True;
+ end if;
+ end;
+ end if;
-- Second case, selected component with same selector, same record
- elsif K1 = N_Selected_Component
+ if K1 = N_Selected_Component
and then K2 = N_Selected_Component
and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2))
then
end if;
end Same_Value;
+ -----------------
+ -- Save_Actual --
+ -----------------
+
+ procedure Save_Actual (N : Node_Id; Writable : Boolean := False) is
+ begin
+ if Ada_Version < Ada_2012 then
+ return;
+
+ elsif Is_Entity_Name (N)
+ or else
+ Nkind_In (N, N_Indexed_Component, N_Selected_Component, N_Slice)
+ or else
+ (Nkind (N) = N_Attribute_Reference
+ and then Attribute_Name (N) = Name_Access)
+
+ then
+ -- We are only interested in IN OUT parameters of inner calls
+
+ if not Writable
+ or else Nkind (Parent (N)) = N_Function_Call
+ or else Nkind (Parent (N)) in N_Op
+ then
+ Actuals_In_Call.Increment_Last;
+ Actuals_In_Call.Table (Actuals_In_Call.Last) := (N, Writable);
+ end if;
+ end if;
+ end Save_Actual;
+
------------------------
-- Scope_Is_Transient --
------------------------
end Set_Size_Info;
--------------------
+ -- Static_Boolean --
+ --------------------
+
+ function Static_Boolean (N : Node_Id) return Uint is
+ begin
+ Analyze_And_Resolve (N, Standard_Boolean);
+
+ if N = Error
+ or else Error_Posted (N)
+ or else Etype (N) = Any_Type
+ then
+ return No_Uint;
+ end if;
+
+ if Is_Static_Expression (N) then
+ if not Raises_Constraint_Error (N) then
+ return Expr_Value (N);
+ else
+ return No_Uint;
+ end if;
+
+ elsif Etype (N) = Any_Type then
+ return No_Uint;
+
+ else
+ Flag_Non_Static_Expr
+ ("static boolean expression required here", N);
+ return No_Uint;
+ end if;
+ end Static_Boolean;
+
+ --------------------
-- Static_Integer --
--------------------
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 --
----------------------
OSDN Git Service
