-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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 Debug; use Debug;
with Errout; use Errout;
with Elists; use Elists;
+with Exp_Ch11; use Exp_Ch11;
with Exp_Disp; use Exp_Disp;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Sem_Aux; use Sem_Aux;
with Sem_Attr; use Sem_Attr;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
+with Sem_SCIL; use Sem_SCIL;
with Sem_Type; use Sem_Type;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Ttypes; use Ttypes;
with Uname; use Uname;
+with GNAT.HTable; use GNAT.HTable;
package body Sem_Util is
+ ----------------------------------------
+ -- Global_Variables for New_Copy_Tree --
+ ----------------------------------------
+
+ -- These global variables are used by New_Copy_Tree. See description
+ -- of the body of this subprogram for details. Global variables can be
+ -- 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;
+ -- 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.
+
+ NCT_Hash_Tables_Used : Boolean := False;
+ -- Set to True if hash tables are in use
+
+ NCT_Table_Entries : Nat;
+ -- Count entries in table to see if threshhold is reached
+
+ NCT_Hash_Table_Setup : Boolean := False;
+ -- Set to True if hash table contains data. We set this True if we
+ -- setup the hash table with data, and leave it set permanently
+ -- from then on, this is a signal that second and subsequent users
+ -- of the hash table must clear the old entries before reuse.
+
+ subtype NCT_Header_Num is Int range 0 .. 511;
+ -- Defines range of headers in hash tables (512 headers)
+
-----------------------
-- Local Subprograms --
-----------------------
Set_Etype (N, Rtyp);
Set_Raises_Constraint_Error (N);
+ -- Now deal with possible local raise handling
+
+ Possible_Local_Raise (N, Standard_Constraint_Error);
+
-- If the original expression was marked as static, the result is
-- still marked as static, but the Raises_Constraint_Error flag is
-- always set so that further static evaluation is not attempted.
end if;
end Cannot_Raise_Constraint_Error;
+ -----------------------------------------
+ -- Check_Dynamically_Tagged_Expression --
+ -----------------------------------------
+
+ procedure Check_Dynamically_Tagged_Expression
+ (Expr : Node_Id;
+ Typ : Entity_Id;
+ Related_Nod : Node_Id)
+ is
+ begin
+ pragma Assert (Is_Tagged_Type (Typ));
+
+ -- In order to avoid spurious errors when analyzing the expanded code,
+ -- this check is done only for nodes that come from source and for
+ -- actuals of generic instantiations.
+
+ if (Comes_From_Source (Related_Nod)
+ or else In_Generic_Actual (Expr))
+ and then (Is_Class_Wide_Type (Etype (Expr))
+ or else Is_Dynamically_Tagged (Expr))
+ and then Is_Tagged_Type (Typ)
+ and then not Is_Class_Wide_Type (Typ)
+ then
+ Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
+ end if;
+ end Check_Dynamically_Tagged_Expression;
+
--------------------------
-- Check_Fully_Declared --
--------------------------
end Denotes_Discriminant;
+ -------------------------
+ -- Denotes_Same_Object --
+ -------------------------
+
+ function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
+ begin
+ -- 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);
+ else
+ return False;
+ end if;
+
+ -- No match if not same node kind
+
+ elsif Nkind (A1) /= Nkind (A2) 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))
+ and then
+ Entity (Selector_Name (A1)) = Entity (Selector_Name (A2));
+
+ -- For explicit dereferences, prefixes must be same
+
+ elsif Nkind (A1) = N_Explicit_Dereference then
+ return Denotes_Same_Object (Prefix (A1), Prefix (A2));
+
+ -- 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
+ declare
+ Indx1 : Node_Id;
+ Indx2 : Node_Id;
+
+ begin
+ Indx1 := First (Expressions (A1));
+ Indx2 := First (Expressions (A2));
+ while Present (Indx1) loop
+
+ -- Shouldn't we be checking that values are the same???
+
+ if not Denotes_Same_Object (Indx1, Indx2) then
+ return False;
+ end if;
+
+ Next (Indx1);
+ Next (Indx2);
+ end loop;
+
+ return True;
+ end;
+ else
+ 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))
+ then
+ declare
+ Lo1, Lo2, Hi1, Hi2 : Node_Id;
+
+ begin
+ Get_Index_Bounds (Etype (A1), Lo1, Hi1);
+ Get_Index_Bounds (Etype (A2), 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
+ -- Known_At_Compile_Time at least if we are generating warnings ???
+
+ elsif Nkind (A1) = N_Integer_Literal then
+ return Intval (A1) = Intval (A2);
+
+ else
+ return False;
+ end if;
+ end Denotes_Same_Object;
+
+ -------------------------
+ -- Denotes_Same_Prefix --
+ -------------------------
+
+ function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is
+
+ begin
+ if Is_Entity_Name (A1) then
+ if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) then
+ return Denotes_Same_Object (A1, Prefix (A2))
+ or else Denotes_Same_Prefix (A1, Prefix (A2));
+ else
+ return False;
+ end if;
+
+ elsif Is_Entity_Name (A2) then
+ return Denotes_Same_Prefix (A2, A1);
+
+ elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice)
+ and then
+ Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice)
+ then
+ declare
+ Root1, Root2 : Node_Id;
+ Depth1, Depth2 : Int := 0;
+
+ begin
+ Root1 := Prefix (A1);
+ while not Is_Entity_Name (Root1) loop
+ if not Nkind_In
+ (Root1, N_Selected_Component, N_Indexed_Component)
+ then
+ return False;
+ else
+ Root1 := Prefix (Root1);
+ end if;
+
+ Depth1 := Depth1 + 1;
+ end loop;
+
+ Root2 := Prefix (A2);
+ while not Is_Entity_Name (Root2) loop
+ if not Nkind_In
+ (Root2, N_Selected_Component, N_Indexed_Component)
+ then
+ return False;
+ else
+ Root2 := Prefix (Root2);
+ end if;
+
+ Depth2 := Depth2 + 1;
+ end loop;
+
+ -- If both have the same depth and they do not denote the same
+ -- object, they are disjoint and not warning is needed.
+
+ if Depth1 = Depth2 then
+ return False;
+
+ elsif Depth1 > Depth2 then
+ Root1 := Prefix (A1);
+ for I in 1 .. Depth1 - Depth2 - 1 loop
+ Root1 := Prefix (Root1);
+ end loop;
+
+ return Denotes_Same_Object (Root1, A2);
+
+ else
+ Root2 := Prefix (A2);
+ for I in 1 .. Depth2 - Depth1 - 1 loop
+ Root2 := Prefix (Root2);
+ end loop;
+
+ return Denotes_Same_Object (A1, Root2);
+ end if;
+ end;
+
+ else
+ return False;
+ end if;
+ end Denotes_Same_Prefix;
+
----------------------
-- Denotes_Variable --
----------------------
end Find_Corresponding_Discriminant;
--------------------------
- -- Find_Overlaid_Object --
+ -- Find_Overlaid_Entity --
--------------------------
- function Find_Overlaid_Object (N : Node_Id) return Entity_Id is
- Expr : Node_Id;
+ procedure Find_Overlaid_Entity
+ (N : Node_Id;
+ Ent : out Entity_Id;
+ Off : out Boolean)
+ is
+ Expr : Node_Id;
begin
-- We are looking for one of the two following forms:
-- In the second case, the expr is either Y'Address, or recursively a
-- constant that eventually references Y'Address.
+ Ent := Empty;
+ Off := False;
+
if Nkind (N) = N_Attribute_Definition_Clause
and then Chars (N) = Name_Address
then
- -- This loop checks the form of the expression for Y'Address where Y
- -- is an object entity name. The first loop checks the original
- -- expression in the attribute definition clause. Subsequent loops
- -- check referenced constants.
-
Expr := Expression (N);
+
+ -- This loop checks the form of the expression for Y'Address,
+ -- using recursion to deal with intermediate constants.
+
loop
- -- Check for Y'Address where Y is an object entity
+ -- Check for Y'Address
if Nkind (Expr) = N_Attribute_Reference
and then Attribute_Name (Expr) = Name_Address
- and then Is_Entity_Name (Prefix (Expr))
- and then Is_Object (Entity (Prefix (Expr)))
then
- return Entity (Prefix (Expr));
+ Expr := Prefix (Expr);
+ exit;
-- Check for Const where Const is a constant entity
-- Anything else does not need checking
else
- exit;
+ return;
end if;
end loop;
- end if;
- return Empty;
- end Find_Overlaid_Object;
+ -- This loop checks the form of the prefix for an entity,
+ -- using recursion to deal with intermediate components.
+
+ loop
+ -- Check for Y where Y is an entity
+
+ if Is_Entity_Name (Expr) then
+ Ent := Entity (Expr);
+ return;
+
+ -- Check for components
+
+ elsif
+ Nkind_In (Expr, N_Selected_Component, N_Indexed_Component) then
+
+ Expr := Prefix (Expr);
+ Off := True;
+
+ -- Anything else does not need checking
+
+ else
+ return;
+ end if;
+ end loop;
+ end if;
+ end Find_Overlaid_Entity;
-------------------------
-- Find_Parameter_Type --
Default : Alignment_Result) return Alignment_Result
is
Result : Alignment_Result := Known_Compatible;
- -- Set to result if Problem_Prefix or Problem_Offset returns True.
- -- Note that once a value of Known_Incompatible is set, it is sticky
- -- and does not get changed to Unknown (the value in Result only gets
- -- worse as we go along, never better).
+ -- Holds the current status of the result. Note that once a value of
+ -- Known_Incompatible is set, it is sticky and does not get changed
+ -- to Unknown (the value in Result only gets worse as we go along,
+ -- never better).
- procedure Check_Offset (Offs : Uint);
- -- Called when Expr is a selected or indexed component with Offs set
- -- to resp Component_First_Bit or Component_Size. Checks that if the
- -- offset is specified it is compatible with the object alignment
- -- requirements. The value in Result is modified accordingly.
+ Offs : Uint := No_Uint;
+ -- Set to a factor of the offset from the base object when Expr is a
+ -- selected or indexed component, based on Component_Bit_Offset and
+ -- Component_Size respectively. A negative value is used to represent
+ -- a value which is not known at compile time.
procedure Check_Prefix;
-- Checks the prefix recursively in the case where the expression
-- compatible, or known incompatible), then set Result to R.
------------------
- -- Check_Offset --
- ------------------
-
- procedure Check_Offset (Offs : Uint) is
- begin
- -- Unspecified or zero offset is always OK
-
- if Offs = No_Uint or else Offs = Uint_0 then
- null;
-
- -- If we do not know required alignment, any non-zero offset is
- -- a potential problem (but certainly may be OK, so result is
- -- unknown).
-
- elsif Unknown_Alignment (Obj) then
- Set_Result (Unknown);
-
- -- If we know the required alignment, see if offset is compatible
-
- else
- if Offs mod (System_Storage_Unit * Alignment (Obj)) /= 0 then
- Set_Result (Known_Incompatible);
- end if;
- end if;
- end Check_Offset;
-
- ------------------
-- Check_Prefix --
------------------
Set_Result (Unknown);
end if;
- -- Check possible bad component offset and check prefix
+ -- Check prefix and component offset
- Check_Offset
- (Component_Bit_Offset (Entity (Selector_Name (Expr))));
Check_Prefix;
+ Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
-- If Expr is an indexed component, we must make sure there is no
-- potentially troublesome Component_Size clause and that the array
-- is not bit-packed.
elsif Nkind (Expr) = N_Indexed_Component then
+ declare
+ Typ : constant Entity_Id := Etype (Prefix (Expr));
+ Ind : constant Node_Id := First_Index (Typ);
- -- Bit packed array always generates unknown alignment
+ begin
+ -- Bit packed array always generates unknown alignment
- if Is_Bit_Packed_Array (Etype (Prefix (Expr))) then
- Set_Result (Unknown);
- end if;
+ if Is_Bit_Packed_Array (Typ) then
+ Set_Result (Unknown);
+ end if;
- -- Check possible bad component size and check prefix
+ -- Check prefix and component offset
- Check_Offset (Component_Size (Etype (Prefix (Expr))));
- Check_Prefix;
+ Check_Prefix;
+ Offs := Component_Size (Typ);
+
+ -- Small optimization: compute the full offset when possible
+
+ if Offs /= No_Uint
+ and then Offs > Uint_0
+ and then Present (Ind)
+ and then Nkind (Ind) = N_Range
+ and then Compile_Time_Known_Value (Low_Bound (Ind))
+ and then Compile_Time_Known_Value (First (Expressions (Expr)))
+ then
+ Offs := Offs * (Expr_Value (First (Expressions (Expr)))
+ - Expr_Value (Low_Bound ((Ind))));
+ end if;
+ end;
end if;
+ -- If we have a null offset, the result is entirely determined by
+ -- the base object and has already been computed recursively.
+
+ if Offs = Uint_0 then
+ null;
+
-- Case where we know the alignment of the object
- if Known_Alignment (Obj) then
+ elsif Known_Alignment (Obj) then
declare
ObjA : constant Uint := Alignment (Obj);
- ExpA : Uint := No_Uint;
- SizA : Uint := No_Uint;
+ ExpA : Uint := No_Uint;
+ SizA : Uint := No_Uint;
begin
-- If alignment of Obj is 1, then we are always OK
-- Alignment of Obj is greater than 1, so we need to check
else
- -- See if Expr is an object with known alignment
+ -- If we have an offset, see if it is compatible
+
+ if Offs /= No_Uint and Offs > Uint_0 then
+ if Offs mod (System_Storage_Unit * ObjA) /= 0 then
+ Set_Result (Known_Incompatible);
+ end if;
+
+ -- See if Expr is an object with known alignment
- if Is_Entity_Name (Expr)
+ elsif Is_Entity_Name (Expr)
and then Known_Alignment (Entity (Expr))
then
ExpA := Alignment (Entity (Expr));
elsif Known_Alignment (Etype (Expr)) then
ExpA := Alignment (Etype (Expr));
+
+ -- Otherwise the alignment is unknown
+
+ else
+ Set_Result (Default);
end if;
-- If we got an alignment, see if it is acceptable
- if ExpA /= No_Uint then
- if ExpA < ObjA then
- Set_Result (Known_Incompatible);
- end if;
+ if ExpA /= No_Uint and then ExpA < ObjA then
+ Set_Result (Known_Incompatible);
+ end if;
- -- Case of Expr alignment unknown
+ -- If Expr is not a piece of a larger object, see if size
+ -- is given. If so, check that it is not too small for the
+ -- required alignment.
- else
- Set_Result (Default);
- end if;
+ if Offs /= No_Uint then
+ null;
- -- See if size is given. If so, check that it is not too
- -- small for the required alignment.
- -- See if Expr is an object with known alignment
+ -- See if Expr is an object with known size
- if Is_Entity_Name (Expr)
+ elsif Is_Entity_Name (Expr)
and then Known_Static_Esize (Entity (Expr))
then
SizA := Esize (Entity (Expr));
end if;
end;
+ -- If we do not know required alignment, any non-zero offset is a
+ -- potential problem (but certainly may be OK, so result is unknown).
+
+ elsif Offs /= No_Uint then
+ Set_Result (Unknown);
+
-- If we can't find the result by direct comparison of alignment
-- values, then there is still one case that we can determine known
-- result, and that is when we can determine that the types are the
if Known_Alignment (Entity (Expr))
and then
- UI_To_Int (Alignment (Entity (Expr)))
- < Ttypes.Maximum_Alignment
+ UI_To_Int (Alignment (Entity (Expr))) <
+ Ttypes.Maximum_Alignment
then
Set_Result (Unknown);
and then
(UI_To_Int (Esize (Entity (Expr))) mod
(Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit))
- /= 0
+ /= 0
then
Set_Result (Unknown);
-- Unknown, since that result will be set in any case.
elsif Default /= Unknown
- and then (Has_Size_Clause (Etype (Expr))
+ and then (Has_Size_Clause (Etype (Expr))
or else
Has_Alignment_Clause (Etype (Expr)))
then
----------------------
function Has_Declarations (N : Node_Id) return Boolean is
- K : constant Node_Kind := Nkind (N);
- begin
- return K = N_Accept_Statement
- or else K = N_Block_Statement
- or else K = N_Compilation_Unit_Aux
- or else K = N_Entry_Body
- or else K = N_Package_Body
- or else K = N_Protected_Body
- or else K = N_Subprogram_Body
- or else K = N_Task_Body
- or else K = N_Package_Specification;
+ begin
+ return Nkind_In (Nkind (N), N_Accept_Statement,
+ N_Block_Statement,
+ N_Compilation_Unit_Aux,
+ N_Entry_Body,
+ N_Package_Body,
+ N_Protected_Body,
+ N_Subprogram_Body,
+ N_Task_Body,
+ N_Package_Specification);
end Has_Declarations;
-------------------------------------------
is
Ifaces_List : Elist_Id;
Elmt : Elmt_Id;
- Iface : Entity_Id;
- Typ : Entity_Id;
+ Iface : Entity_Id := Base_Type (Iface_Ent);
+ Typ : Entity_Id := Base_Type (Typ_Ent);
begin
- if Is_Class_Wide_Type (Typ_Ent) then
- Typ := Etype (Typ_Ent);
- else
- Typ := Typ_Ent;
- end if;
-
- if Is_Class_Wide_Type (Iface_Ent) then
- Iface := Etype (Iface_Ent);
- else
- Iface := Iface_Ent;
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Root_Type (Typ);
end if;
if not Has_Interfaces (Typ) then
return False;
end if;
+ if Is_Class_Wide_Type (Iface) then
+ Iface := Root_Type (Iface);
+ end if;
+
Collect_Interfaces (Typ, Ifaces_List);
Elmt := First_Elmt (Ifaces_List);
begin
Save_Interps (N, New_Prefix);
- Rewrite (N,
- Make_Explicit_Dereference (Sloc (N),
- Prefix => New_Prefix));
+
+ -- Check if the node relocation requires readjustment of some SCIL
+ -- dispatching node.
+
+ if Generate_SCIL
+ and then Nkind (N) = N_Function_Call
+ then
+ Adjust_SCIL_Node (N, New_Prefix);
+ end if;
+
+ Rewrite (N, Make_Explicit_Dereference (Sloc (N), Prefix => New_Prefix));
Set_Etype (N, Designated_Type (Etype (New_Prefix)));
if Is_Overloaded (New_Prefix) then
- -- The deference is also overloaded, and its interpretations are the
- -- designated types of the interpretations of the original node.
+ -- The dereference is also overloaded, and its interpretations are
+ -- the designated types of the interpretations of the original node.
Set_Etype (N, Any_Type);
and then E = Base_Type (E);
end Is_AAMP_Float;
+ -----------------------------
+ -- Is_Actual_Out_Parameter --
+ -----------------------------
+
+ function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is
+ Formal : Entity_Id;
+ Call : Node_Id;
+ begin
+ Find_Actual (N, Formal, Call);
+ return Present (Formal)
+ and then Ekind (Formal) = E_Out_Parameter;
+ end Is_Actual_Out_Parameter;
+
-------------------------
-- Is_Actual_Parameter --
-------------------------
return False;
end Is_Controlling_Limited_Procedure;
+ -----------------------------
+ -- Is_CPP_Constructor_Call --
+ -----------------------------
+
+ function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is
+ begin
+ return Nkind (N) = N_Function_Call
+ and then Is_CPP_Class (Etype (Etype (N)))
+ and then Is_Constructor (Entity (Name (N)))
+ and then Is_Imported (Entity (Name (N)));
+ end Is_CPP_Constructor_Call;
+
----------------------------------------------
-- Is_Dependent_Component_Of_Mutable_Object --
----------------------------------------------
-- uninitialized case. Note that this applies both to the
-- uTag entry and the main vtable pointer (CPP_Class case).
- and then (VM_Target = No_VM or else not Is_Tag (Ent))
+ and then (Tagged_Type_Expansion or else not Is_Tag (Ent))
then
return False;
end if;
end if;
end Is_Fully_Initialized_Variant;
+ ------------
+ -- Is_LHS --
+ ------------
+
+ -- We seem to have a lot of overlapping functions that do similar things
+ -- (testing for left hand sides or lvalues???). Anyway, since this one is
+ -- purely syntactic, it should be in Sem_Aux I would think???
+
+ 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;
+ end Is_LHS;
+
----------------------------
-- Is_Inherited_Operation --
----------------------------
function Is_Value_Type (T : Entity_Id) return Boolean is
begin
return VM_Target = CLI_Target
+ and then Nkind (T) in N_Has_Chars
and then Chars (T) /= No_Name
and then Get_Name_String (Chars (T)) = "valuetype";
end Is_Value_Type;
-----------------
+ -- Is_Delegate --
+ -----------------
+
+ function Is_Delegate (T : Entity_Id) return Boolean is
+ Desig_Type : Entity_Id;
+
+ begin
+ if VM_Target /= CLI_Target then
+ return False;
+ end if;
+
+ -- Access-to-subprograms are delegates in CIL
+
+ if Ekind (T) = E_Access_Subprogram_Type then
+ return True;
+ end if;
+
+ if Ekind (T) not in Access_Kind then
+
+ -- A delegate is a managed pointer. If no designated type is defined
+ -- it means that it's not a delegate.
+
+ return False;
+ end if;
+
+ Desig_Type := Etype (Directly_Designated_Type (T));
+
+ if not Is_Tagged_Type (Desig_Type) then
+ return False;
+ end if;
+
+ -- Test if the type is inherited from [mscorlib]System.Delegate
+
+ while Etype (Desig_Type) /= Desig_Type loop
+ if Chars (Scope (Desig_Type)) /= No_Name
+ and then Is_Imported (Scope (Desig_Type))
+ and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate"
+ then
+ return True;
+ end if;
+
+ Desig_Type := Etype (Desig_Type);
+ end loop;
+
+ return False;
+ end Is_Delegate;
+
+ -----------------
-- Is_Variable --
-----------------
function Is_Variable (N : Node_Id) return Boolean is
Orig_Node : constant Node_Id := Original_Node (N);
- -- We do the test on the original node, since this is basically a
- -- test of syntactic categories, so it must not be disturbed by
- -- whatever rewriting might have occurred. For example, an aggregate,
- -- which is certainly NOT a variable, could be turned into a variable
- -- by expansion.
+ -- We do the test on the original node, since this is basically a test
+ -- of syntactic categories, so it must not be disturbed by whatever
+ -- rewriting might have occurred. For example, an aggregate, which is
+ -- certainly NOT a variable, could be turned into a variable by
+ -- expansion.
function In_Protected_Function (E : Entity_Id) return Boolean;
-- Within a protected function, the private components of the
end if;
end Is_Variable;
+ ---------------------------
+ -- Is_Visibly_Controlled --
+ ---------------------------
+
+ function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
+ Root : constant Entity_Id := Root_Type (T);
+ begin
+ return Chars (Scope (Root)) = Name_Finalization
+ and then Chars (Scope (Scope (Root))) = Name_Ada
+ and then Scope (Scope (Scope (Root))) = Standard_Standard;
+ end Is_Visibly_Controlled;
+
------------------------
-- Is_Volatile_Object --
------------------------
Last_Assignment_Only : Boolean := False)
is
begin
+ -- ??? do we have to worry about clearing cached checks?
+
if Is_Assignable (Ent) then
Set_Last_Assignment (Ent, Empty);
end if;
- if not Last_Assignment_Only and then Is_Object (Ent) then
- Kill_Checks (Ent);
- Set_Current_Value (Ent, Empty);
+ if Is_Object (Ent) then
+ if not Last_Assignment_Only then
+ Kill_Checks (Ent);
+ Set_Current_Value (Ent, Empty);
- if not Can_Never_Be_Null (Ent) then
- Set_Is_Known_Non_Null (Ent, False);
- end if;
+ if not Can_Never_Be_Null (Ent) then
+ Set_Is_Known_Non_Null (Ent, False);
+ end if;
+
+ Set_Is_Known_Null (Ent, False);
- Set_Is_Known_Null (Ent, False);
+ -- Reset Is_Known_Valid unless type is always valid, or if we have
+ -- a loop parameter (loop parameters are always valid, since their
+ -- bounds are defined by the bounds given in the loop header).
+
+ if not Is_Known_Valid (Etype (Ent))
+ and then Ekind (Ent) /= E_Loop_Parameter
+ then
+ Set_Is_Known_Valid (Ent, False);
+ end if;
+ end if;
end if;
end Kill_Current_Values;
when N_Assignment_Statement =>
return N = Name (P);
- -- Test prefix of component or attribute
+ -- Test prefix of component or attribute. Note that the prefix of an
+ -- explicit or implicit dereference cannot be an l-value.
when N_Attribute_Reference =>
return N = Prefix (P)
and then Name_Implies_Lvalue_Prefix (Attribute_Name (P));
- when N_Expanded_Name |
- N_Explicit_Dereference |
- N_Indexed_Component |
- N_Reference |
- N_Selected_Component |
- N_Slice =>
- return N = Prefix (P);
+ -- For an expanded name, the name is an lvalue if the expanded name
+ -- is an lvalue, but the prefix is never an lvalue, since it is just
+ -- the scope where the name is found.
+
+ when N_Expanded_Name =>
+ if N = Prefix (P) then
+ return May_Be_Lvalue (P);
+ else
+ return False;
+ end if;
+
+ -- For a selected component A.B, A is certainly an lvalue if A.B is.
+ -- B is a little interesting, if we have A.B := 3, there is some
+ -- discussion as to whether B is an lvalue or not, we choose to say
+ -- it is. Note however that A is not an lvalue if it is of an access
+ -- type since this is an implicit dereference.
+
+ when N_Selected_Component =>
+ if N = Prefix (P)
+ and then Present (Etype (N))
+ and then Is_Access_Type (Etype (N))
+ then
+ return False;
+ else
+ return May_Be_Lvalue (P);
+ end if;
+
+ -- For an indexed component or slice, the index or slice bounds is
+ -- never an lvalue. The prefix is an lvalue if the indexed component
+ -- or slice is an lvalue, except if it is an access type, where we
+ -- have an implicit dereference.
+
+ when N_Indexed_Component =>
+ if N /= Prefix (P)
+ or else (Present (Etype (N)) and then Is_Access_Type (Etype (N)))
+ then
+ return False;
+ else
+ return May_Be_Lvalue (P);
+ end if;
+
+ -- Prefix of a reference is an lvalue if the reference is an lvalue
+
+ when N_Reference =>
+ return May_Be_Lvalue (P);
+
+ -- Prefix of explicit dereference is never an lvalue
+
+ when N_Explicit_Dereference =>
+ return False;
-- Function call arguments are never lvalues
when N_Object_Renaming_Declaration =>
return True;
- -- All other references are definitely not Lvalues
+ -- All other references are definitely not lvalues
when others =>
return False;
end if;
end Needs_One_Actual;
+ ------------------------
+ -- New_Copy_List_Tree --
+ ------------------------
+
+ function New_Copy_List_Tree (List : List_Id) return List_Id is
+ NL : List_Id;
+ E : Node_Id;
+
+ begin
+ if List = No_List then
+ return No_List;
+
+ else
+ NL := New_List;
+ E := First (List);
+
+ while Present (E) loop
+ Append (New_Copy_Tree (E), NL);
+ E := Next (E);
+ end loop;
+
+ return NL;
+ end if;
+ end New_Copy_List_Tree;
+
+ -------------------
+ -- New_Copy_Tree --
+ -------------------
+
+ use Atree.Unchecked_Access;
+ use Atree_Private_Part;
+
+ -- Our approach here requires a two pass traversal of the tree. The
+ -- first pass visits all nodes that eventually will be copied looking
+ -- for defining Itypes. If any defining Itypes are found, then they are
+ -- copied, and an entry is added to the replacement map. In the second
+ -- phase, the tree is copied, using the replacement map to replace any
+ -- 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
+ -- 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.
+
+ function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
+ -- Hash function used for hash operations
+
+ -------------------
+ -- New_Copy_Hash --
+ -------------------
+
+ function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
+ begin
+ return Nat (E) mod (NCT_Header_Num'Last + 1);
+ end New_Copy_Hash;
+
+ ---------------
+ -- NCT_Assoc --
+ ---------------
+
+ -- The hash table NCT_Assoc associates old entities in the table
+ -- with their corresponding new entities (i.e. the pairs of entries
+ -- presented in the original Map argument are Key-Element pairs).
+
+ package NCT_Assoc is new Simple_HTable (
+ Header_Num => NCT_Header_Num,
+ Element => Entity_Id,
+ No_Element => Empty,
+ Key => Entity_Id,
+ Hash => New_Copy_Hash,
+ Equal => Types."=");
+
+ ---------------------
+ -- NCT_Itype_Assoc --
+ ---------------------
+
+ -- The hash table NCT_Itype_Assoc contains entries only for those
+ -- old nodes which have a non-empty Associated_Node_For_Itype set.
+ -- The key is the associated node, and the element is the new node
+ -- itself (NOT the associated node for the new node).
+
+ package NCT_Itype_Assoc is new Simple_HTable (
+ Header_Num => NCT_Header_Num,
+ Element => Entity_Id,
+ No_Element => Empty,
+ Key => Entity_Id,
+ Hash => New_Copy_Hash,
+ Equal => Types."=");
+
+ -- Start of processing for New_Copy_Tree function
+
+ function New_Copy_Tree
+ (Source : Node_Id;
+ Map : Elist_Id := No_Elist;
+ New_Sloc : Source_Ptr := No_Location;
+ New_Scope : Entity_Id := Empty) return Node_Id
+ is
+ Actual_Map : Elist_Id := Map;
+ -- This is the actual map for the copy. It is initialized with the
+ -- given elements, and then enlarged as required for Itypes that are
+ -- copied during the first phase of the copy operation. The visit
+ -- procedures add elements to this map as Itypes are encountered.
+ -- The reason we cannot use Map directly, is that it may well be
+ -- (and normally is) initialized to No_Elist, and if we have mapped
+ -- entities, we have to reset it to point to a real Elist.
+
+ function Assoc (N : Node_Or_Entity_Id) return Node_Id;
+ -- Called during second phase to map entities into their corresponding
+ -- copies using Actual_Map. If the argument is not an entity, or is not
+ -- in Actual_Map, then it is returned unchanged.
+
+ procedure Build_NCT_Hash_Tables;
+ -- Builds hash tables (number of elements >= threshold value)
+
+ function Copy_Elist_With_Replacement
+ (Old_Elist : Elist_Id) return Elist_Id;
+ -- Called during second phase to copy element list doing replacements
+
+ procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id);
+ -- Called during the second phase to process a copied Itype. The actual
+ -- copy happened during the first phase (so that we could make the entry
+ -- in the mapping), but we still have to deal with the descendents of
+ -- the copied Itype and copy them where necessary.
+
+ function Copy_List_With_Replacement (Old_List : List_Id) return List_Id;
+ -- Called during second phase to copy list doing replacements
+
+ function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id;
+ -- Called during second phase to copy node doing replacements
+
+ procedure Visit_Elist (E : Elist_Id);
+ -- Called during first phase to visit all elements of an Elist
+
+ procedure Visit_Field (F : Union_Id; N : Node_Id);
+ -- Visit a single field, recursing to call Visit_Node or Visit_List
+ -- if the field is a syntactic descendent of the current node (i.e.
+ -- its parent is Node N).
+
+ procedure Visit_Itype (Old_Itype : Entity_Id);
+ -- Called during first phase to visit subsidiary fields of a defining
+ -- Itype, and also create a copy and make an entry in the replacement
+ -- map for the new copy.
+
+ procedure Visit_List (L : List_Id);
+ -- Called during first phase to visit all elements of a List
+
+ procedure Visit_Node (N : Node_Or_Entity_Id);
+ -- Called during first phase to visit a node and all its subtrees
+
+ -----------
+ -- Assoc --
+ -----------
+
+ function Assoc (N : Node_Or_Entity_Id) return Node_Id is
+ E : Elmt_Id;
+ Ent : Entity_Id;
+
+ begin
+ if not Has_Extension (N) or else No (Actual_Map) then
+ return N;
+
+ elsif NCT_Hash_Tables_Used then
+ Ent := NCT_Assoc.Get (Entity_Id (N));
+
+ if Present (Ent) then
+ return Ent;
+ else
+ return N;
+ end if;
+
+ -- No hash table used, do serial search
+
+ else
+ E := First_Elmt (Actual_Map);
+ while Present (E) loop
+ if Node (E) = N then
+ return Node (Next_Elmt (E));
+ else
+ E := Next_Elmt (Next_Elmt (E));
+ end if;
+ end loop;
+ end if;
+
+ return N;
+ end Assoc;
+
+ ---------------------------
+ -- Build_NCT_Hash_Tables --
+ ---------------------------
+
+ procedure Build_NCT_Hash_Tables is
+ Elmt : Elmt_Id;
+ Ent : Entity_Id;
+ begin
+ if NCT_Hash_Table_Setup then
+ NCT_Assoc.Reset;
+ NCT_Itype_Assoc.Reset;
+ end if;
+
+ Elmt := First_Elmt (Actual_Map);
+ while Present (Elmt) loop
+ Ent := Node (Elmt);
+
+ -- Get new entity, and associate old and new
+
+ Next_Elmt (Elmt);
+ NCT_Assoc.Set (Ent, Node (Elmt));
+
+ if Is_Type (Ent) then
+ declare
+ Anode : constant Entity_Id :=
+ Associated_Node_For_Itype (Ent);
+
+ begin
+ if Present (Anode) then
+
+ -- Enter a link between the associated node of the
+ -- old Itype and the new Itype, for updating later
+ -- when node is copied.
+
+ NCT_Itype_Assoc.Set (Anode, Node (Elmt));
+ end if;
+ end;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ NCT_Hash_Tables_Used := True;
+ NCT_Hash_Table_Setup := True;
+ end Build_NCT_Hash_Tables;
+
+ ---------------------------------
+ -- Copy_Elist_With_Replacement --
+ ---------------------------------
+
+ function Copy_Elist_With_Replacement
+ (Old_Elist : Elist_Id) return Elist_Id
+ is
+ M : Elmt_Id;
+ New_Elist : Elist_Id;
+
+ begin
+ if No (Old_Elist) then
+ return No_Elist;
+
+ else
+ New_Elist := New_Elmt_List;
+
+ M := First_Elmt (Old_Elist);
+ while Present (M) loop
+ Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist);
+ Next_Elmt (M);
+ end loop;
+ end if;
+
+ return New_Elist;
+ end Copy_Elist_With_Replacement;
+
+ ---------------------------------
+ -- Copy_Itype_With_Replacement --
+ ---------------------------------
+
+ -- This routine exactly parallels its phase one analog Visit_Itype,
+
+ procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is
+ begin
+ -- Translate Next_Entity, Scope and Etype fields, in case they
+ -- reference entities that have been mapped into copies.
+
+ Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype)));
+ Set_Etype (New_Itype, Assoc (Etype (New_Itype)));
+
+ if Present (New_Scope) then
+ Set_Scope (New_Itype, New_Scope);
+ else
+ Set_Scope (New_Itype, Assoc (Scope (New_Itype)));
+ end if;
+
+ -- Copy referenced fields
+
+ if Is_Discrete_Type (New_Itype) then
+ Set_Scalar_Range (New_Itype,
+ Copy_Node_With_Replacement (Scalar_Range (New_Itype)));
+
+ elsif Has_Discriminants (Base_Type (New_Itype)) then
+ Set_Discriminant_Constraint (New_Itype,
+ Copy_Elist_With_Replacement
+ (Discriminant_Constraint (New_Itype)));
+
+ elsif Is_Array_Type (New_Itype) then
+ if Present (First_Index (New_Itype)) then
+ Set_First_Index (New_Itype,
+ First (Copy_List_With_Replacement
+ (List_Containing (First_Index (New_Itype)))));
+ end if;
+
+ if Is_Packed (New_Itype) then
+ Set_Packed_Array_Type (New_Itype,
+ Copy_Node_With_Replacement
+ (Packed_Array_Type (New_Itype)));
+ end if;
+ end if;
+ end Copy_Itype_With_Replacement;
+
+ --------------------------------
+ -- Copy_List_With_Replacement --
+ --------------------------------
+
+ function Copy_List_With_Replacement
+ (Old_List : List_Id) return List_Id
+ is
+ New_List : List_Id;
+ E : Node_Id;
+
+ begin
+ if Old_List = No_List then
+ return No_List;
+
+ else
+ New_List := Empty_List;
+
+ E := First (Old_List);
+ while Present (E) loop
+ Append (Copy_Node_With_Replacement (E), New_List);
+ Next (E);
+ end loop;
+
+ return New_List;
+ end if;
+ end Copy_List_With_Replacement;
+
+ --------------------------------
+ -- Copy_Node_With_Replacement --
+ --------------------------------
+
+ function Copy_Node_With_Replacement
+ (Old_Node : Node_Id) return Node_Id
+ is
+ New_Node : Node_Id;
+
+ procedure Adjust_Named_Associations
+ (Old_Node : Node_Id;
+ New_Node : Node_Id);
+ -- If a call node has named associations, these are chained through
+ -- the First_Named_Actual, Next_Named_Actual links. These must be
+ -- propagated separately to the new parameter list, because these
+ -- are not syntactic fields.
+
+ function Copy_Field_With_Replacement
+ (Field : Union_Id) return Union_Id;
+ -- Given Field, which is a field of Old_Node, return a copy of it
+ -- if it is a syntactic field (i.e. its parent is Node), setting
+ -- the parent of the copy to poit to New_Node. Otherwise returns
+ -- the field (possibly mapped if it is an entity).
+
+ -------------------------------
+ -- Adjust_Named_Associations --
+ -------------------------------
+
+ procedure Adjust_Named_Associations
+ (Old_Node : Node_Id;
+ New_Node : Node_Id)
+ is
+ Old_E : Node_Id;
+ New_E : Node_Id;
+
+ Old_Next : Node_Id;
+ New_Next : Node_Id;
+
+ begin
+ Old_E := First (Parameter_Associations (Old_Node));
+ New_E := First (Parameter_Associations (New_Node));
+ while Present (Old_E) loop
+ if Nkind (Old_E) = N_Parameter_Association
+ and then Present (Next_Named_Actual (Old_E))
+ then
+ if First_Named_Actual (Old_Node)
+ = Explicit_Actual_Parameter (Old_E)
+ then
+ Set_First_Named_Actual
+ (New_Node, Explicit_Actual_Parameter (New_E));
+ end if;
+
+ -- Now scan parameter list from the beginning,to locate
+ -- next named actual, which can be out of order.
+
+ Old_Next := First (Parameter_Associations (Old_Node));
+ New_Next := First (Parameter_Associations (New_Node));
+
+ while Nkind (Old_Next) /= N_Parameter_Association
+ or else Explicit_Actual_Parameter (Old_Next)
+ /= Next_Named_Actual (Old_E)
+ loop
+ Next (Old_Next);
+ Next (New_Next);
+ end loop;
+
+ Set_Next_Named_Actual
+ (New_E, Explicit_Actual_Parameter (New_Next));
+ end if;
+
+ Next (Old_E);
+ Next (New_E);
+ end loop;
+ end Adjust_Named_Associations;
+
+ ---------------------------------
+ -- Copy_Field_With_Replacement --
+ ---------------------------------
+
+ function Copy_Field_With_Replacement
+ (Field : Union_Id) return Union_Id
+ is
+ begin
+ if Field = Union_Id (Empty) then
+ return Field;
+
+ elsif Field in Node_Range then
+ declare
+ Old_N : constant Node_Id := Node_Id (Field);
+ New_N : Node_Id;
+
+ begin
+ -- If syntactic field, as indicated by the parent pointer
+ -- being set, then copy the referenced node recursively.
+
+ if Parent (Old_N) = Old_Node then
+ New_N := Copy_Node_With_Replacement (Old_N);
+
+ if New_N /= Old_N then
+ Set_Parent (New_N, New_Node);
+ end if;
+
+ -- For semantic fields, update possible entity reference
+ -- from the replacement map.
+
+ else
+ New_N := Assoc (Old_N);
+ end if;
+
+ return Union_Id (New_N);
+ end;
+
+ elsif Field in List_Range then
+ declare
+ Old_L : constant List_Id := List_Id (Field);
+ New_L : List_Id;
+
+ begin
+ -- If syntactic field, as indicated by the parent pointer,
+ -- then recursively copy the entire referenced list.
+
+ if Parent (Old_L) = Old_Node then
+ New_L := Copy_List_With_Replacement (Old_L);
+ Set_Parent (New_L, New_Node);
+
+ -- For semantic list, just returned unchanged
+
+ else
+ New_L := Old_L;
+ end if;
+
+ return Union_Id (New_L);
+ end;
+
+ -- Anything other than a list or a node is returned unchanged
+
+ else
+ return Field;
+ end if;
+ end Copy_Field_With_Replacement;
+
+ -- Start of processing for Copy_Node_With_Replacement
+
+ begin
+ if Old_Node <= Empty_Or_Error then
+ return Old_Node;
+
+ elsif Has_Extension (Old_Node) then
+ return Assoc (Old_Node);
+
+ else
+ New_Node := New_Copy (Old_Node);
+
+ -- If the node we are copying is the associated node of a
+ -- previously copied Itype, then adjust the associated node
+ -- of the copy of that Itype accordingly.
+
+ if Present (Actual_Map) then
+ declare
+ E : Elmt_Id;
+ Ent : Entity_Id;
+
+ begin
+ -- Case of hash table used
+
+ if NCT_Hash_Tables_Used then
+ Ent := NCT_Itype_Assoc.Get (Old_Node);
+
+ if Present (Ent) then
+ Set_Associated_Node_For_Itype (Ent, New_Node);
+ end if;
+
+ -- Case of no hash table used
+
+ else
+ E := First_Elmt (Actual_Map);
+ while Present (E) loop
+ if Is_Itype (Node (E))
+ and then
+ Old_Node = Associated_Node_For_Itype (Node (E))
+ then
+ Set_Associated_Node_For_Itype
+ (Node (Next_Elmt (E)), New_Node);
+ end if;
+
+ E := Next_Elmt (Next_Elmt (E));
+ end loop;
+ end if;
+ end;
+ end if;
+
+ -- Recursively copy descendents
+
+ Set_Field1
+ (New_Node, Copy_Field_With_Replacement (Field1 (New_Node)));
+ Set_Field2
+ (New_Node, Copy_Field_With_Replacement (Field2 (New_Node)));
+ Set_Field3
+ (New_Node, Copy_Field_With_Replacement (Field3 (New_Node)));
+ Set_Field4
+ (New_Node, Copy_Field_With_Replacement (Field4 (New_Node)));
+ Set_Field5
+ (New_Node, Copy_Field_With_Replacement (Field5 (New_Node)));
+
+ -- Adjust Sloc of new node if necessary
+
+ if New_Sloc /= No_Location then
+ Set_Sloc (New_Node, New_Sloc);
+
+ -- If we adjust the Sloc, then we are essentially making
+ -- a completely new node, so the Comes_From_Source flag
+ -- should be reset to the proper default value.
+
+ Nodes.Table (New_Node).Comes_From_Source :=
+ Default_Node.Comes_From_Source;
+ end if;
+
+ -- If the node is call and has named associations,
+ -- set the corresponding links in the copy.
+
+ if (Nkind (Old_Node) = N_Function_Call
+ or else Nkind (Old_Node) = N_Entry_Call_Statement
+ or else
+ Nkind (Old_Node) = N_Procedure_Call_Statement)
+ and then Present (First_Named_Actual (Old_Node))
+ then
+ Adjust_Named_Associations (Old_Node, New_Node);
+ end if;
+
+ -- Reset First_Real_Statement for Handled_Sequence_Of_Statements.
+ -- The replacement mechanism applies to entities, and is not used
+ -- here. Eventually we may need a more general graph-copying
+ -- routine. For now, do a sequential search to find desired node.
+
+ if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements
+ and then Present (First_Real_Statement (Old_Node))
+ then
+ declare
+ Old_F : constant Node_Id := First_Real_Statement (Old_Node);
+ N1, N2 : Node_Id;
+
+ begin
+ N1 := First (Statements (Old_Node));
+ N2 := First (Statements (New_Node));
+
+ while N1 /= Old_F loop
+ Next (N1);
+ Next (N2);
+ end loop;
+
+ Set_First_Real_Statement (New_Node, N2);
+ end;
+ end if;
+ end if;
+
+ -- All done, return copied node
+
+ return New_Node;
+ end Copy_Node_With_Replacement;
+
+ -----------------
+ -- Visit_Elist --
+ -----------------
+
+ procedure Visit_Elist (E : Elist_Id) is
+ Elmt : Elmt_Id;
+ begin
+ if Present (E) then
+ Elmt := First_Elmt (E);
+
+ while Elmt /= No_Elmt loop
+ Visit_Node (Node (Elmt));
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+ end Visit_Elist;
+
+ -----------------
+ -- Visit_Field --
+ -----------------
+
+ procedure Visit_Field (F : Union_Id; N : Node_Id) is
+ begin
+ if F = Union_Id (Empty) then
+ return;
+
+ elsif F in Node_Range then
+
+ -- Copy node if it is syntactic, i.e. its parent pointer is
+ -- set to point to the field that referenced it (certain
+ -- Itypes will also meet this criterion, which is fine, since
+ -- these are clearly Itypes that do need to be copied, since
+ -- we are copying their parent.)
+
+ if Parent (Node_Id (F)) = N then
+ Visit_Node (Node_Id (F));
+ return;
+
+ -- Another case, if we are pointing to an Itype, then we want
+ -- to copy it if its associated node is somewhere in the tree
+ -- being copied.
+
+ -- Note: the exclusion of self-referential copies is just an
+ -- optimization, since the search of the already copied list
+ -- would catch it, but it is a common case (Etype pointing
+ -- to itself for an Itype that is a base type).
+
+ elsif Has_Extension (Node_Id (F))
+ and then Is_Itype (Entity_Id (F))
+ and then Node_Id (F) /= N
+ then
+ declare
+ P : Node_Id;
+
+ begin
+ P := Associated_Node_For_Itype (Node_Id (F));
+ while Present (P) loop
+ if P = Source then
+ Visit_Node (Node_Id (F));
+ return;
+ else
+ P := Parent (P);
+ end if;
+ end loop;
+
+ -- An Itype whose parent is not being copied definitely
+ -- should NOT be copied, since it does not belong in any
+ -- sense to the copied subtree.
+
+ return;
+ end;
+ end if;
+
+ elsif F in List_Range
+ and then Parent (List_Id (F)) = N
+ then
+ Visit_List (List_Id (F));
+ return;
+ end if;
+ end Visit_Field;
+
+ -----------------
+ -- Visit_Itype --
+ -----------------
+
+ procedure Visit_Itype (Old_Itype : Entity_Id) is
+ New_Itype : Entity_Id;
+ E : Elmt_Id;
+ Ent : Entity_Id;
+
+ begin
+ -- Itypes that describe the designated type of access to subprograms
+ -- have the structure of subprogram declarations, with signatures,
+ -- etc. Either we duplicate the signatures completely, or choose to
+ -- share such itypes, which is fine because their elaboration will
+ -- have no side effects.
+
+ if Ekind (Old_Itype) = E_Subprogram_Type then
+ return;
+ end if;
+
+ New_Itype := New_Copy (Old_Itype);
+
+ -- The new Itype has all the attributes of the old one, and
+ -- we just copy the contents of the entity. However, the back-end
+ -- needs different names for debugging purposes, so we create a
+ -- new internal name for it in all cases.
+
+ Set_Chars (New_Itype, New_Internal_Name ('T'));
+
+ -- If our associated node is an entity that has already been copied,
+ -- then set the associated node of the copy to point to the right
+ -- copy. If we have copied an Itype that is itself the associated
+ -- node of some previously copied Itype, then we set the right
+ -- pointer in the other direction.
+
+ if Present (Actual_Map) then
+
+ -- Case of hash tables used
+
+ if NCT_Hash_Tables_Used then
+
+ Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
+
+ if Present (Ent) then
+ Set_Associated_Node_For_Itype (New_Itype, Ent);
+ end if;
+
+ Ent := NCT_Itype_Assoc.Get (Old_Itype);
+ if Present (Ent) then
+ Set_Associated_Node_For_Itype (Ent, New_Itype);
+
+ -- If the hash table has no association for this Itype and
+ -- its associated node, enter one now.
+
+ else
+ NCT_Itype_Assoc.Set
+ (Associated_Node_For_Itype (Old_Itype), New_Itype);
+ end if;
+
+ -- Case of hash tables not used
+
+ else
+ E := First_Elmt (Actual_Map);
+ while Present (E) loop
+ if Associated_Node_For_Itype (Old_Itype) = Node (E) then
+ Set_Associated_Node_For_Itype
+ (New_Itype, Node (Next_Elmt (E)));
+ end if;
+
+ if Is_Type (Node (E))
+ and then
+ Old_Itype = Associated_Node_For_Itype (Node (E))
+ then
+ Set_Associated_Node_For_Itype
+ (Node (Next_Elmt (E)), New_Itype);
+ end if;
+
+ E := Next_Elmt (Next_Elmt (E));
+ end loop;
+ end if;
+ end if;
+
+ if Present (Freeze_Node (New_Itype)) then
+ Set_Is_Frozen (New_Itype, False);
+ Set_Freeze_Node (New_Itype, Empty);
+ end if;
+
+ -- Add new association to map
+
+ if No (Actual_Map) then
+ Actual_Map := New_Elmt_List;
+ end if;
+
+ Append_Elmt (Old_Itype, Actual_Map);
+ Append_Elmt (New_Itype, Actual_Map);
+
+ if NCT_Hash_Tables_Used then
+ NCT_Assoc.Set (Old_Itype, New_Itype);
+
+ else
+ NCT_Table_Entries := NCT_Table_Entries + 1;
+
+ if NCT_Table_Entries > NCT_Hash_Threshhold then
+ Build_NCT_Hash_Tables;
+ end if;
+ end if;
+
+ -- If a record subtype is simply copied, the entity list will be
+ -- shared. Thus cloned_Subtype must be set to indicate the sharing.
+
+ if Ekind (Old_Itype) = E_Record_Subtype
+ or else Ekind (Old_Itype) = E_Class_Wide_Subtype
+ then
+ Set_Cloned_Subtype (New_Itype, Old_Itype);
+ end if;
+
+ -- Visit descendents that eventually get copied
+
+ Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype);
+
+ if Is_Discrete_Type (Old_Itype) then
+ Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype);
+
+ elsif Has_Discriminants (Base_Type (Old_Itype)) then
+ -- ??? This should involve call to Visit_Field
+ Visit_Elist (Discriminant_Constraint (Old_Itype));
+
+ elsif Is_Array_Type (Old_Itype) then
+ if Present (First_Index (Old_Itype)) then
+ Visit_Field (Union_Id (List_Containing
+ (First_Index (Old_Itype))),
+ Old_Itype);
+ end if;
+
+ if Is_Packed (Old_Itype) then
+ Visit_Field (Union_Id (Packed_Array_Type (Old_Itype)),
+ Old_Itype);
+ end if;
+ end if;
+ end Visit_Itype;
+
+ ----------------
+ -- Visit_List --
+ ----------------
+
+ procedure Visit_List (L : List_Id) is
+ N : Node_Id;
+ begin
+ if L /= No_List then
+ N := First (L);
+
+ while Present (N) loop
+ Visit_Node (N);
+ Next (N);
+ end loop;
+ end if;
+ end Visit_List;
+
+ ----------------
+ -- Visit_Node --
+ ----------------
+
+ procedure Visit_Node (N : Node_Or_Entity_Id) is
+
+ -- Start of processing for Visit_Node
+
+ begin
+ -- Handle case of an Itype, which must be copied
+
+ if Has_Extension (N)
+ and then Is_Itype (N)
+ then
+ -- Nothing to do if already in the list. This can happen with an
+ -- Itype entity that appears more than once in the tree.
+ -- Note that we do not want to visit descendents in this case.
+
+ -- Test for already in list when hash table is used
+
+ if NCT_Hash_Tables_Used then
+ if Present (NCT_Assoc.Get (Entity_Id (N))) then
+ return;
+ end if;
+
+ -- Test for already in list when hash table not used
+
+ else
+ declare
+ E : Elmt_Id;
+ begin
+ if Present (Actual_Map) then
+ E := First_Elmt (Actual_Map);
+ while Present (E) loop
+ if Node (E) = N then
+ return;
+ else
+ E := Next_Elmt (Next_Elmt (E));
+ end if;
+ end loop;
+ end if;
+ end;
+ end if;
+
+ Visit_Itype (N);
+ end if;
+
+ -- Visit descendents
+
+ Visit_Field (Field1 (N), N);
+ Visit_Field (Field2 (N), N);
+ Visit_Field (Field3 (N), N);
+ Visit_Field (Field4 (N), N);
+ Visit_Field (Field5 (N), N);
+ end Visit_Node;
+
+ -- Start of processing for New_Copy_Tree
+
+ begin
+ Actual_Map := Map;
+
+ -- See if we should use hash table
+
+ if No (Actual_Map) then
+ NCT_Hash_Tables_Used := False;
+
+ else
+ declare
+ Elmt : Elmt_Id;
+
+ begin
+ NCT_Table_Entries := 0;
+
+ Elmt := First_Elmt (Actual_Map);
+ while Present (Elmt) loop
+ NCT_Table_Entries := NCT_Table_Entries + 1;
+ Next_Elmt (Elmt);
+ Next_Elmt (Elmt);
+ end loop;
+
+ if NCT_Table_Entries > NCT_Hash_Threshhold then
+ Build_NCT_Hash_Tables;
+ else
+ NCT_Hash_Tables_Used := False;
+ end if;
+ end;
+ end if;
+
+ -- Hash table set up if required, now start phase one by visiting
+ -- top node (we will recursively visit the descendents).
+
+ Visit_Node (Source);
+
+ -- Now the second phase of the copy can start. First we process
+ -- all the mapped entities, copying their descendents.
+
+ if Present (Actual_Map) then
+ declare
+ Elmt : Elmt_Id;
+ New_Itype : Entity_Id;
+ begin
+ Elmt := First_Elmt (Actual_Map);
+ while Present (Elmt) loop
+ Next_Elmt (Elmt);
+ New_Itype := Node (Elmt);
+ Copy_Itype_With_Replacement (New_Itype);
+ Next_Elmt (Elmt);
+ end loop;
+ end;
+ end if;
+
+ -- Now we can copy the actual tree
+
+ return Copy_Node_With_Replacement (Source);
+ end New_Copy_Tree;
+
-------------------------
-- New_External_Entity --
-------------------------
return Token_Node;
end Real_Convert;
+ ------------------------------------
+ -- References_Generic_Formal_Type --
+ ------------------------------------
+
+ function References_Generic_Formal_Type (N : Node_Id) return Boolean is
+
+ function Process (N : Node_Id) return Traverse_Result;
+ -- Process one node in search for generic formal type
+
+ -------------
+ -- Process --
+ -------------
+
+ function Process (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) in N_Has_Entity then
+ declare
+ E : constant Entity_Id := Entity (N);
+ begin
+ if Present (E) then
+ if Is_Generic_Type (E) then
+ return Abandon;
+ elsif Present (Etype (E))
+ and then Is_Generic_Type (Etype (E))
+ then
+ return Abandon;
+ end if;
+ end if;
+ end;
+ end if;
+
+ return Atree.OK;
+ end Process;
+
+ function Traverse is new Traverse_Func (Process);
+ -- Traverse tree to look for generic type
+
+ begin
+ if Inside_A_Generic then
+ return Traverse (N) = Abandon;
+ else
+ return False;
+ end if;
+ end References_Generic_Formal_Type;
+
--------------------
-- Remove_Homonym --
--------------------
P := Parent (N);
while Present (P) loop
- if Nkind (P) = N_If_Statement
+ if Nkind (P) = N_If_Statement
or else Nkind (P) = N_Case_Statement
- or else (Nkind (P) = N_And_Then and then Desc = Right_Opnd (P))
- or else (Nkind (P) = N_Or_Else and then Desc = Right_Opnd (P))
+ or else (Nkind (P) in N_Short_Circuit
+ and then Desc = Right_Opnd (P))
+ or else (Nkind (P) = N_Conditional_Expression
+ and then Desc /= First (Expressions (P)))
or else Nkind (P) = N_Exception_Handler
or else Nkind (P) = N_Selective_Accept
or else Nkind (P) = N_Conditional_Entry_Call
end loop;
end;
+ if Ekind (T) = E_Class_Wide_Subtype then
+ Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T));
+ end if;
+
elsif Is_Array_Type (T) then
Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
begin
-- Deal with indexed or selected component where prefix is modified
- if Nkind (N) = N_Indexed_Component
- or else
- Nkind (N) = N_Selected_Component
- then
+ if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
Pref := Prefix (N);
-- If prefix is access type, then it is the designated object that is
Error_Msg_NE ("\\found}!", Expr, Found_Type);
end if;
+ -- A special check for cases like M1 and M2 = 0 where M1 and M2 are
+ -- of the same modular type, and (M1 and M2) = 0 was intended.
+
+ if Expec_Type = Standard_Boolean
+ and then Is_Modular_Integer_Type (Found_Type)
+ and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor)
+ and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare
+ then
+ declare
+ Op : constant Node_Id := Right_Opnd (Parent (Expr));
+ L : constant Node_Id := Left_Opnd (Op);
+ R : constant Node_Id := Right_Opnd (Op);
+ begin
+ -- The case for the message is when the left operand of the
+ -- comparison is the same modular type, or when it is an
+ -- integer literal (or other universal integer expression),
+ -- which would have been typed as the modular type if the
+ -- parens had been there.
+
+ if (Etype (L) = Found_Type
+ or else
+ Etype (L) = Universal_Integer)
+ and then Is_Integer_Type (Etype (R))
+ then
+ Error_Msg_N
+ ("\\possible missing parens for modular operation", Expr);
+ end if;
+ end;
+ end if;
+
+ -- Reset error message qualification indication
+
Error_Msg_Qual_Level := 0;
end if;
end Wrong_Type;
OSDN Git Service
