with Debug; use Debug;
with Elists; use Elists;
with Errout; use Errout;
+with Erroutc; use Erroutc;
with Exp_Ch11; use Exp_Ch11;
with Exp_Disp; use Exp_Disp;
with Exp_Util; use Exp_Util;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Disp; use Sem_Disp;
+with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
-- becomes Requires_Transient_Scope and Old_Requires_Transient_Scope is
-- eliminated.
+ function Subprogram_Name (N : Node_Id) return String;
+ -- Return the fully qualified name of the enclosing subprogram for the
+ -- given node N, with file:line:col information appended, e.g.
+ -- "subp:file:line:col", corresponding to the source location of the
+ -- body of the subprogram.
+
------------------------------
-- Abstract_Interface_List --
------------------------------
end case;
end All_Composite_Constraints_Static;
+ ------------------------
+ -- Append_Entity_Name --
+ ------------------------
+
+ procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id) is
+ Temp : Bounded_String;
+
+ procedure Inner (E : Entity_Id);
+ -- Inner recursive routine, keep outer routine nonrecursive to ease
+ -- debugging when we get strange results from this routine.
+
+ -----------
+ -- Inner --
+ -----------
+
+ procedure Inner (E : Entity_Id) is
+ Scop : Node_Id;
+
+ begin
+ -- If entity has an internal name, skip by it, and print its scope.
+ -- Note that we strip a final R from the name before the test; this
+ -- is needed for some cases of instantiations.
+
+ declare
+ E_Name : Bounded_String;
+
+ begin
+ Append (E_Name, Chars (E));
+
+ if E_Name.Chars (E_Name.Length) = 'R' then
+ E_Name.Length := E_Name.Length - 1;
+ end if;
+
+ if Is_Internal_Name (E_Name) then
+ Inner (Scope (E));
+ return;
+ end if;
+ end;
+
+ Scop := Scope (E);
+
+ -- Just print entity name if its scope is at the outer level
+
+ if Scop = Standard_Standard then
+ null;
+
+ -- If scope comes from source, write scope and entity
+
+ elsif Comes_From_Source (Scop) then
+ Append_Entity_Name (Temp, Scop);
+ Append (Temp, '.');
+
+ -- If in wrapper package skip past it
+
+ elsif Present (Scop) and then Is_Wrapper_Package (Scop) then
+ Append_Entity_Name (Temp, Scope (Scop));
+ Append (Temp, '.');
+
+ -- Otherwise nothing to output (happens in unnamed block statements)
+
+ else
+ null;
+ end if;
+
+ -- Output the name
+
+ declare
+ E_Name : Bounded_String;
+
+ begin
+ Append_Unqualified_Decoded (E_Name, Chars (E));
+
+ -- Remove trailing upper-case letters from the name (useful for
+ -- dealing with some cases of internal names generated in the case
+ -- of references from within a generic).
+
+ while E_Name.Length > 1
+ and then E_Name.Chars (E_Name.Length) in 'A' .. 'Z'
+ loop
+ E_Name.Length := E_Name.Length - 1;
+ end loop;
+
+ -- Adjust casing appropriately (gets name from source if possible)
+
+ Adjust_Name_Case (E_Name, Sloc (E));
+ Append (Temp, E_Name);
+ end;
+ end Inner;
+
+ -- Start of processing for Append_Entity_Name
+
+ begin
+ Inner (E);
+ Append (Buf, Temp);
+ end Append_Entity_Name;
+
---------------------------------
-- Append_Inherited_Subprogram --
---------------------------------
and then not In_Same_Extended_Unit (N, T);
end Bad_Unordered_Enumeration_Reference;
+ ----------------------------
+ -- Begin_Keyword_Location --
+ ----------------------------
+
+ function Begin_Keyword_Location (N : Node_Id) return Source_Ptr is
+ HSS : Node_Id;
+
+ begin
+ pragma Assert (Nkind_In (N, N_Block_Statement,
+ N_Entry_Body,
+ N_Package_Body,
+ N_Subprogram_Body,
+ N_Task_Body));
+
+ HSS := Handled_Statement_Sequence (N);
+
+ -- When the handled sequence of statements comes from source, the
+ -- location of the "begin" keyword is that of the sequence itself.
+ -- Note that an internal construct may inherit a source sequence.
+
+ if Comes_From_Source (HSS) then
+ return Sloc (HSS);
+
+ -- The parser generates an internal handled sequence of statements to
+ -- capture the location of the "begin" keyword if present in the source.
+ -- Since there are no source statements, the location of the "begin"
+ -- keyword is effectively that of the "end" keyword.
+
+ elsif Comes_From_Source (N) then
+ return Sloc (HSS);
+
+ -- Otherwise the construct is internal and should carry the location of
+ -- the original construct which prompted its creation.
+
+ else
+ return Sloc (N);
+ end if;
+ end Begin_Keyword_Location;
+
--------------------------
-- Build_Actual_Subtype --
--------------------------
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);
-- second occurrence, the error is reported, and the tree traversal
-- is abandoned.
- function Get_Function_Id (Call : Node_Id) return Entity_Id;
- -- Return the entity associated with the function call
-
procedure Preanalyze_Without_Errors (N : Node_Id);
-- Preanalyze N without reporting errors. Very dubious, you can't just
-- go analyzing things more than once???
Formal : Node_Id;
begin
- Id := Get_Function_Id (Call);
+ Id := Get_Called_Entity (Call);
-- In case of previous error, no check is possible
Do_Traversal (N);
end Collect_Identifiers;
- ---------------------
- -- Get_Function_Id --
- ---------------------
-
- function Get_Function_Id (Call : Node_Id) return Entity_Id is
- Nam : constant Node_Id := Name (Call);
- Id : Entity_Id;
-
- begin
- if Nkind (Nam) = N_Explicit_Dereference then
- Id := Etype (Nam);
- pragma Assert (Ekind (Id) = E_Subprogram_Type);
-
- elsif Nkind (Nam) = N_Selected_Component then
- Id := Entity (Selector_Name (Nam));
-
- elsif Nkind (Nam) = N_Indexed_Component then
- Id := Entity (Selector_Name (Prefix (Nam)));
-
- else
- Id := Entity (Nam);
- end if;
-
- return Id;
- end Get_Function_Id;
-
-------------------------------
-- Preanalyze_Without_Errors --
-------------------------------
| N_Subprogram_Call
=>
declare
- Id : constant Entity_Id := Get_Function_Id (N);
+ Id : constant Entity_Id := Get_Called_Entity (N);
Formal : Node_Id;
Actual : Node_Id;
---------------------------
procedure Check_No_Hidden_State (Id : Entity_Id) is
- function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean;
- -- Determine whether the entity of a package denoted by Pkg has a null
- -- abstract state.
-
- -----------------------------
- -- Has_Null_Abstract_State --
- -----------------------------
-
- function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean is
- States : constant Elist_Id := Abstract_States (Pkg);
-
- begin
- -- Check first available state of related package. A null abstract
- -- state always appears as the sole element of the state list.
-
- return
- Present (States)
- and then Is_Null_State (Node (First_Elmt (States)));
- end Has_Null_Abstract_State;
-
- -- Local variables
-
Context : Entity_Id := Empty;
Not_Visible : Boolean := False;
Scop : Entity_Id;
- -- Start of processing for Check_No_Hidden_State
-
begin
pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable));
and then not Comes_From_Source (Par)
then
-- Continue to examine the context if the reference appears in a
- -- subprogram body which was previously an expression function.
+ -- subprogram body which was previously an expression function,
+ -- unless this is during preanalysis (when In_Spec_Expression is
+ -- True), as the body may not yet be inserted in the tree.
if Nkind (Par) = N_Subprogram_Body
and then Was_Expression_Function (Par)
+ and then not In_Spec_Expression
then
null;
-- Returns True if the message applies to a conjunct in the
-- expression, instead of the whole expression.
+ function Has_Global_Output (Subp : Entity_Id) return Boolean;
+ -- Returns True if Subp has an output in its Global contract
+
+ function Has_No_Output (Subp : Entity_Id) return Boolean;
+ -- Returns True if Subp has no declared output: no function
+ -- result, no output parameter, and no output in its Global
+ -- contract.
+
--------------------
-- Adjust_Message --
--------------------
or else Split_PPC (Prag);
end Applied_On_Conjunct;
+ -----------------------
+ -- Has_Global_Output --
+ -----------------------
+
+ function Has_Global_Output (Subp : Entity_Id) return Boolean is
+ Global : constant Node_Id := Get_Pragma (Subp, Pragma_Global);
+ List : Node_Id;
+ Assoc : Node_Id;
+
+ begin
+ if No (Global) then
+ return False;
+ end if;
+
+ List := Expression (Get_Argument (Global, Subp));
+
+ -- Empty list (no global items) or single global item
+ -- declaration (only input items).
+
+ if Nkind_In (List, N_Null,
+ N_Expanded_Name,
+ N_Identifier,
+ N_Selected_Component)
+ then
+ return False;
+
+ -- Simple global list (only input items) or moded global list
+ -- declaration.
+
+ elsif Nkind (List) = N_Aggregate then
+ if Present (Expressions (List)) then
+ return False;
+
+ else
+ Assoc := First (Component_Associations (List));
+ while Present (Assoc) loop
+ if Chars (First (Choices (Assoc))) /= Name_Input then
+ return True;
+ end if;
+
+ Next (Assoc);
+ end loop;
+
+ return False;
+ end if;
+
+ -- To accommodate partial decoration of disabled SPARK
+ -- features, this routine may be called with illegal input.
+ -- If this is the case, do not raise Program_Error.
+
+ else
+ return False;
+ end if;
+ end Has_Global_Output;
+
+ -------------------
+ -- Has_No_Output --
+ -------------------
+
+ function Has_No_Output (Subp : Entity_Id) return Boolean is
+ Param : Node_Id;
+
+ begin
+ -- A function has its result as output
+
+ if Ekind (Subp) = E_Function then
+ return False;
+ end if;
+
+ -- An OUT or IN OUT parameter is an output
+
+ Param := First_Formal (Subp);
+ while Present (Param) loop
+ if Ekind_In (Param, E_Out_Parameter, E_In_Out_Parameter) then
+ return False;
+ end if;
+
+ Next_Formal (Param);
+ end loop;
+
+ -- An item of mode Output or In_Out in the Global contract is
+ -- an output.
+
+ if Has_Global_Output (Subp) then
+ return False;
+ end if;
+
+ return True;
+ end Has_No_Output;
+
-- Local variables
Err_Node : Node_Id;
Err_Node := Prag;
end if;
+ -- Do not report missing reference to outcome in postcondition if
+ -- either the postcondition is trivially True or False, or if the
+ -- subprogram is ghost and has no declared output.
+
if not Is_Trivial_Boolean (Expr)
and then not Mentions_Post_State (Expr)
+ and then not (Is_Ghost_Entity (Subp_Id)
+ and then Has_No_Output (Subp_Id))
then
if Pragma_Name (Prag) = Name_Contract_Cases then
Error_Msg_NE (Adjust_Message
if SPARK_Mode_Is_Off (Pack) then
null;
- -- State refinement can only occur in a completing packge body. Do
+ -- State refinement can only occur in a completing package body. Do
-- not verify proper state refinement when the body is subject to
-- pragma SPARK_Mode Off because this disables the requirement for
-- state refinement.
end if;
end Conditional_Delay;
- ----------------------------
- -- Contains_Refined_State --
- ----------------------------
+ -------------------------
+ -- Copy_Component_List --
+ -------------------------
- function Contains_Refined_State (Prag : Node_Id) return Boolean is
- function Has_State_In_Dependency (List : Node_Id) return Boolean;
- -- Determine whether a dependency list mentions a state with a visible
- -- refinement.
+ function Copy_Component_List
+ (R_Typ : Entity_Id;
+ Loc : Source_Ptr) return List_Id
+ is
+ Comp : Node_Id;
+ Comps : constant List_Id := New_List;
- function Has_State_In_Global (List : Node_Id) return Boolean;
- -- Determine whether a global list mentions a state with a visible
- -- refinement.
+ begin
+ Comp := First_Component (Underlying_Type (R_Typ));
+ while Present (Comp) loop
+ if Comes_From_Source (Comp) then
+ declare
+ Comp_Decl : constant Node_Id := Declaration_Node (Comp);
+ begin
+ Append_To (Comps,
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Chars (Comp)),
+ Component_Definition =>
+ New_Copy_Tree
+ (Component_Definition (Comp_Decl), New_Sloc => Loc)));
+ end;
+ end if;
- function Is_Refined_State (Item : Node_Id) return Boolean;
- -- Determine whether Item is a reference to an abstract state with a
- -- visible refinement.
+ Next_Component (Comp);
+ end loop;
- -----------------------------
- -- Has_State_In_Dependency --
- -----------------------------
+ return Comps;
+ end Copy_Component_List;
- function Has_State_In_Dependency (List : Node_Id) return Boolean is
- Clause : Node_Id;
- Output : Node_Id;
+ -------------------------
+ -- Copy_Parameter_List --
+ -------------------------
- begin
- -- A null dependency list does not mention any states
+ function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is
+ Loc : constant Source_Ptr := Sloc (Subp_Id);
+ Plist : List_Id;
+ Formal : Entity_Id;
- if Nkind (List) = N_Null then
- return False;
+ begin
+ if No (First_Formal (Subp_Id)) then
+ return No_List;
+ else
+ Plist := New_List;
+ Formal := First_Formal (Subp_Id);
+ while Present (Formal) loop
+ Append_To (Plist,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
+ In_Present => In_Present (Parent (Formal)),
+ Out_Present => Out_Present (Parent (Formal)),
+ Parameter_Type =>
+ New_Occurrence_Of (Etype (Formal), Loc),
+ Expression =>
+ New_Copy_Tree (Expression (Parent (Formal)))));
- -- Dependency clauses appear as component associations of an
- -- aggregate.
+ Next_Formal (Formal);
+ end loop;
+ end if;
- elsif Nkind (List) = N_Aggregate
- and then Present (Component_Associations (List))
- then
- Clause := First (Component_Associations (List));
- while Present (Clause) loop
+ return Plist;
+ end Copy_Parameter_List;
- -- Inspect the outputs of a dependency clause
+ ----------------------------
+ -- Copy_SPARK_Mode_Aspect --
+ ----------------------------
- Output := First (Choices (Clause));
- while Present (Output) loop
- if Is_Refined_State (Output) then
- return True;
- end if;
+ procedure Copy_SPARK_Mode_Aspect (From : Node_Id; To : Node_Id) is
+ pragma Assert (not Has_Aspects (To));
+ Asp : Node_Id;
- Next (Output);
- end loop;
+ begin
+ if Has_Aspects (From) then
+ Asp := Find_Aspect (Defining_Entity (From), Aspect_SPARK_Mode);
- -- Inspect the outputs of a dependency clause
+ if Present (Asp) then
+ Set_Aspect_Specifications (To, New_List (New_Copy_Tree (Asp)));
+ Set_Has_Aspects (To, True);
+ end if;
+ end if;
+ end Copy_SPARK_Mode_Aspect;
- if Is_Refined_State (Expression (Clause)) then
- return True;
- end if;
+ --------------------------
+ -- Copy_Subprogram_Spec --
+ --------------------------
- Next (Clause);
- end loop;
+ function Copy_Subprogram_Spec (Spec : Node_Id) return Node_Id is
+ Def_Id : Node_Id;
+ Formal_Spec : Node_Id;
+ Result : Node_Id;
- -- If we get here, then none of the dependency clauses mention a
- -- state with visible refinement.
+ begin
+ -- The structure of the original tree must be replicated without any
+ -- alterations. Use New_Copy_Tree for this purpose.
- return False;
+ Result := New_Copy_Tree (Spec);
- -- An illegal pragma managed to sneak in
-
- else
- raise Program_Error;
- end if;
- end Has_State_In_Dependency;
-
- -------------------------
- -- Has_State_In_Global --
- -------------------------
-
- function Has_State_In_Global (List : Node_Id) return Boolean is
- Item : Node_Id;
-
- begin
- -- A null global list does not mention any states
-
- if Nkind (List) = N_Null then
- return False;
-
- -- Simple global list or moded global list declaration
-
- elsif Nkind (List) = N_Aggregate then
-
- -- The declaration of a simple global list appear as a collection
- -- of expressions.
-
- if Present (Expressions (List)) then
- Item := First (Expressions (List));
- while Present (Item) loop
- if Is_Refined_State (Item) then
- return True;
- end if;
-
- Next (Item);
- end loop;
-
- -- The declaration of a moded global list appears as a collection
- -- of component associations where individual choices denote
- -- modes.
-
- else
- Item := First (Component_Associations (List));
- while Present (Item) loop
- if Has_State_In_Global (Expression (Item)) then
- return True;
- end if;
-
- Next (Item);
- end loop;
- end if;
-
- -- If we get here, then the simple/moded global list did not
- -- mention any states with a visible refinement.
-
- return False;
-
- -- Single global item declaration
-
- elsif Is_Entity_Name (List) then
- return Is_Refined_State (List);
-
- -- An illegal pragma managed to sneak in
-
- else
- raise Program_Error;
- end if;
- end Has_State_In_Global;
-
- ----------------------
- -- Is_Refined_State --
- ----------------------
-
- function Is_Refined_State (Item : Node_Id) return Boolean is
- Elmt : Node_Id;
- Item_Id : Entity_Id;
-
- begin
- if Nkind (Item) = N_Null then
- return False;
-
- -- States cannot be subject to attribute 'Result. This case arises
- -- in dependency relations.
-
- elsif Nkind (Item) = N_Attribute_Reference
- and then Attribute_Name (Item) = Name_Result
- then
- return False;
-
- -- Multiple items appear as an aggregate. This case arises in
- -- dependency relations.
-
- elsif Nkind (Item) = N_Aggregate
- and then Present (Expressions (Item))
- then
- Elmt := First (Expressions (Item));
- while Present (Elmt) loop
- if Is_Refined_State (Elmt) then
- return True;
- end if;
-
- Next (Elmt);
- end loop;
-
- -- If we get here, then none of the inputs or outputs reference a
- -- state with visible refinement.
-
- return False;
-
- -- Single item
-
- else
- Item_Id := Entity_Of (Item);
-
- return
- Present (Item_Id)
- and then Ekind (Item_Id) = E_Abstract_State
- and then Has_Visible_Refinement (Item_Id);
- end if;
- end Is_Refined_State;
-
- -- Local variables
-
- Arg : constant Node_Id :=
- Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
- Nam : constant Name_Id := Pragma_Name (Prag);
-
- -- Start of processing for Contains_Refined_State
-
- begin
- if Nam = Name_Depends then
- return Has_State_In_Dependency (Arg);
-
- else pragma Assert (Nam = Name_Global);
- return Has_State_In_Global (Arg);
- end if;
- end Contains_Refined_State;
-
- -------------------------
- -- Copy_Component_List --
- -------------------------
-
- function Copy_Component_List
- (R_Typ : Entity_Id;
- Loc : Source_Ptr) return List_Id
- is
- Comp : Node_Id;
- Comps : constant List_Id := New_List;
-
- begin
- Comp := First_Component (Underlying_Type (R_Typ));
- while Present (Comp) loop
- if Comes_From_Source (Comp) then
- declare
- Comp_Decl : constant Node_Id := Declaration_Node (Comp);
- begin
- Append_To (Comps,
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Chars (Comp)),
- Component_Definition =>
- New_Copy_Tree
- (Component_Definition (Comp_Decl), New_Sloc => Loc)));
- end;
- end if;
-
- Next_Component (Comp);
- end loop;
-
- return Comps;
- end Copy_Component_List;
-
- -------------------------
- -- Copy_Parameter_List --
- -------------------------
-
- function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is
- Loc : constant Source_Ptr := Sloc (Subp_Id);
- Plist : List_Id;
- Formal : Entity_Id;
-
- begin
- if No (First_Formal (Subp_Id)) then
- return No_List;
- else
- Plist := New_List;
- Formal := First_Formal (Subp_Id);
- while Present (Formal) loop
- Append_To (Plist,
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
- In_Present => In_Present (Parent (Formal)),
- Out_Present => Out_Present (Parent (Formal)),
- Parameter_Type =>
- New_Occurrence_Of (Etype (Formal), Loc),
- Expression =>
- New_Copy_Tree (Expression (Parent (Formal)))));
-
- Next_Formal (Formal);
- end loop;
- end if;
-
- return Plist;
- end Copy_Parameter_List;
-
- ----------------------------
- -- Copy_SPARK_Mode_Aspect --
- ----------------------------
-
- procedure Copy_SPARK_Mode_Aspect (From : Node_Id; To : Node_Id) is
- pragma Assert (not Has_Aspects (To));
- Asp : Node_Id;
-
- begin
- if Has_Aspects (From) then
- Asp := Find_Aspect (Defining_Entity (From), Aspect_SPARK_Mode);
-
- if Present (Asp) then
- Set_Aspect_Specifications (To, New_List (New_Copy_Tree (Asp)));
- Set_Has_Aspects (To, True);
- end if;
- end if;
- end Copy_SPARK_Mode_Aspect;
-
- --------------------------
- -- Copy_Subprogram_Spec --
- --------------------------
-
- function Copy_Subprogram_Spec (Spec : Node_Id) return Node_Id is
- Def_Id : Node_Id;
- Formal_Spec : Node_Id;
- Result : Node_Id;
-
- begin
- -- The structure of the original tree must be replicated without any
- -- alterations. Use New_Copy_Tree for this purpose.
-
- Result := New_Copy_Tree (Spec);
-
- -- However, the spec of a null procedure carries the corresponding null
- -- statement of the body (created by the parser), and this cannot be
- -- shared with the new subprogram spec.
+ -- However, the spec of a null procedure carries the corresponding null
+ -- statement of the body (created by the parser), and this cannot be
+ -- shared with the new subprogram spec.
if Nkind (Result) = N_Procedure_Specification then
Set_Null_Statement (Result, Empty);
---------------------
function Defining_Entity
- (N : Node_Id;
- Empty_On_Errors : Boolean := False) return Entity_Id
+ (N : Node_Id;
+ Empty_On_Errors : Boolean := False;
+ Concurrent_Subunit : Boolean := False) return Entity_Id
is
- Err : Entity_Id := Empty;
-
begin
case Nkind (N) is
when N_Abstract_Subprogram_Declaration
return Defining_Identifier (N);
when N_Subunit =>
- return Defining_Entity (Proper_Body (N));
+ declare
+ Bod : constant Node_Id := Proper_Body (N);
+ Orig_Bod : constant Node_Id := Original_Node (Bod);
+
+ begin
+ -- Retrieve the entity of the original protected or task body
+ -- if requested by the caller.
+
+ if Concurrent_Subunit
+ and then Nkind (Bod) = N_Null_Statement
+ and then Nkind_In (Orig_Bod, N_Protected_Body, N_Task_Body)
+ then
+ return Defining_Entity (Orig_Bod);
+ else
+ return Defining_Entity (Bod);
+ end if;
+ end;
when N_Function_Instantiation
| N_Function_Specification
=>
declare
Nam : constant Node_Id := Defining_Unit_Name (N);
+ Err : Entity_Id := Empty;
begin
if Nkind (Nam) in N_Entity then
end if;
end Enclosing_Subprogram;
+ --------------------------
+ -- End_Keyword_Location --
+ --------------------------
+
+ function End_Keyword_Location (N : Node_Id) return Source_Ptr is
+ function End_Label_Loc (Nod : Node_Id) return Source_Ptr;
+ -- Return the source location of Nod's end label according to the
+ -- following precedence rules:
+ --
+ -- 1) If the end label exists, return its location
+ -- 2) If Nod exists, return its location
+ -- 3) Return the location of N
+
+ -------------------
+ -- End_Label_Loc --
+ -------------------
+
+ function End_Label_Loc (Nod : Node_Id) return Source_Ptr is
+ Label : Node_Id;
+
+ begin
+ if Present (Nod) then
+ Label := End_Label (Nod);
+
+ if Present (Label) then
+ return Sloc (Label);
+ else
+ return Sloc (Nod);
+ end if;
+
+ else
+ return Sloc (N);
+ end if;
+ end End_Label_Loc;
+
+ -- Local variables
+
+ Owner : Node_Id;
+
+ -- Start of processing for End_Keyword_Location
+
+ begin
+ if Nkind_In (N, N_Block_Statement,
+ N_Entry_Body,
+ N_Package_Body,
+ N_Subprogram_Body,
+ N_Task_Body)
+ then
+ Owner := Handled_Statement_Sequence (N);
+
+ elsif Nkind (N) = N_Package_Declaration then
+ Owner := Specification (N);
+
+ elsif Nkind (N) = N_Protected_Body then
+ Owner := N;
+
+ elsif Nkind_In (N, N_Protected_Type_Declaration,
+ N_Single_Protected_Declaration)
+ then
+ Owner := Protected_Definition (N);
+
+ elsif Nkind_In (N, N_Single_Task_Declaration,
+ N_Task_Type_Declaration)
+ then
+ Owner := Task_Definition (N);
+
+ -- This routine should not be called with other contexts
+
+ else
+ pragma Assert (False);
+ null;
+ end if;
+
+ return End_Label_Loc (Owner);
+ end End_Keyword_Location;
+
------------------------
-- Ensure_Freeze_Node --
------------------------
raise Program_Error;
end Find_Corresponding_Discriminant;
- ----------------------------------
- -- Find_Enclosing_Iterator_Loop --
- ----------------------------------
+ -------------------
+ -- Find_DIC_Type --
+ -------------------
- function Find_Enclosing_Iterator_Loop (Id : Entity_Id) return Entity_Id is
- Constr : Node_Id;
- S : Entity_Id;
+ function Find_DIC_Type (Typ : Entity_Id) return Entity_Id is
+ Curr_Typ : Entity_Id;
+ -- The current type being examined in the parent hierarchy traversal
+
+ DIC_Typ : Entity_Id;
+ -- The type which carries the DIC pragma. This variable denotes the
+ -- partial view when private types are involved.
+
+ Par_Typ : Entity_Id;
+ -- The parent type of the current type. This variable denotes the full
+ -- view when private types are involved.
begin
- -- Traverse the scope chain looking for an iterator loop. Such loops are
- -- usually transformed into blocks, hence the use of Original_Node.
+ -- The input type defines its own DIC pragma, therefore it is the owner
- S := Id;
- while Present (S) and then S /= Standard_Standard loop
- if Ekind (S) = E_Loop
- and then Nkind (Parent (S)) = N_Implicit_Label_Declaration
- then
- Constr := Original_Node (Label_Construct (Parent (S)));
+ if Has_Own_DIC (Typ) then
+ DIC_Typ := Typ;
- if Nkind (Constr) = N_Loop_Statement
- and then Present (Iteration_Scheme (Constr))
- and then Nkind (Iterator_Specification
- (Iteration_Scheme (Constr))) =
+ -- Otherwise the DIC pragma is inherited from a parent type
+
+ else
+ pragma Assert (Has_Inherited_DIC (Typ));
+
+ -- Climb the parent chain
+
+ Curr_Typ := Typ;
+ loop
+ -- Inspect the parent type. Do not consider subtypes as they
+ -- inherit the DIC attributes from their base types.
+
+ DIC_Typ := Base_Type (Etype (Curr_Typ));
+
+ -- Look at the full view of a private type because the type may
+ -- have a hidden parent introduced in the full view.
+
+ Par_Typ := DIC_Typ;
+
+ if Is_Private_Type (Par_Typ)
+ and then Present (Full_View (Par_Typ))
+ then
+ Par_Typ := Full_View (Par_Typ);
+ end if;
+
+ -- Stop the climb once the nearest parent type which defines a DIC
+ -- pragma of its own is encountered or when the root of the parent
+ -- chain is reached.
+
+ exit when Has_Own_DIC (DIC_Typ) or else Curr_Typ = Par_Typ;
+
+ Curr_Typ := Par_Typ;
+ end loop;
+ end if;
+
+ return DIC_Typ;
+ end Find_DIC_Type;
+
+ ----------------------------------
+ -- Find_Enclosing_Iterator_Loop --
+ ----------------------------------
+
+ function Find_Enclosing_Iterator_Loop (Id : Entity_Id) return Entity_Id is
+ Constr : Node_Id;
+ S : Entity_Id;
+
+ begin
+ -- Traverse the scope chain looking for an iterator loop. Such loops are
+ -- usually transformed into blocks, hence the use of Original_Node.
+
+ S := Id;
+ while Present (S) and then S /= Standard_Standard loop
+ if Ekind (S) = E_Loop
+ and then Nkind (Parent (S)) = N_Implicit_Label_Declaration
+ then
+ Constr := Original_Node (Label_Construct (Parent (S)));
+
+ if Nkind (Constr) = N_Loop_Statement
+ and then Present (Iteration_Scheme (Constr))
+ and then Nkind (Iterator_Specification
+ (Iteration_Scheme (Constr))) =
N_Iterator_Specification
then
return S;
return Empty;
end Find_Enclosing_Iterator_Loop;
+ --------------------------
+ -- Find_Enclosing_Scope --
+ --------------------------
+
+ function Find_Enclosing_Scope (N : Node_Id) return Entity_Id is
+ Par : Node_Id;
+ Spec_Id : Entity_Id;
+
+ begin
+ -- Examine the parent chain looking for a construct which defines a
+ -- scope.
+
+ Par := Parent (N);
+ while Present (Par) loop
+ case Nkind (Par) is
+
+ -- The construct denotes a declaration, the proper scope is its
+ -- entity.
+
+ when N_Entry_Declaration
+ | N_Expression_Function
+ | N_Full_Type_Declaration
+ | N_Generic_Package_Declaration
+ | N_Generic_Subprogram_Declaration
+ | N_Package_Declaration
+ | N_Private_Extension_Declaration
+ | N_Protected_Type_Declaration
+ | N_Single_Protected_Declaration
+ | N_Single_Task_Declaration
+ | N_Subprogram_Declaration
+ | N_Task_Type_Declaration
+ =>
+ return Defining_Entity (Par);
+
+ -- The construct denotes a body, the proper scope is the entity of
+ -- the corresponding spec.
+
+ when N_Entry_Body
+ | N_Package_Body
+ | N_Protected_Body
+ | N_Subprogram_Body
+ | N_Task_Body
+ =>
+ Spec_Id := Corresponding_Spec (Par);
+
+ -- The defining entity of a stand-alone subprogram body defines
+ -- a scope.
+
+ if Nkind (Par) = N_Subprogram_Body and then No (Spec_Id) then
+ return Defining_Entity (Par);
+
+ -- Otherwise there should be corresponding spec which defines a
+ -- scope.
+
+ else
+ pragma Assert (Present (Spec_Id));
+
+ return Spec_Id;
+ end if;
+
+ -- Special cases
+
+ -- Blocks carry either a source or an internally-generated scope,
+ -- unless the block is a byproduct of exception handling.
+
+ when N_Block_Statement =>
+ if not Exception_Junk (Par) then
+ return Entity (Identifier (Par));
+ end if;
+
+ -- Loops carry an internally-generated scope
+
+ when N_Loop_Statement =>
+ return Entity (Identifier (Par));
+
+ -- Extended return statements carry an internally-generated scope
+
+ when N_Extended_Return_Statement =>
+ return Return_Statement_Entity (Par);
+
+ -- A traversal from a subunit continues via the corresponding stub
+
+ when N_Subunit =>
+ Par := Corresponding_Stub (Par);
+
+ when others =>
+ null;
+ end case;
+
+ Par := Parent (Par);
+ end loop;
+
+ return Standard_Standard;
+ end Find_Enclosing_Scope;
+
------------------------------------
-- Find_Loop_In_Conditional_Block --
------------------------------------
Context := Scope (Item_Id);
while Present (Context) and then Context /= Standard_Standard loop
- if Ekind (Context) = E_Package then
+ if Is_Package_Or_Generic_Package (Context) then
Pack_Id := Context;
-- A package body is a cut off point for the traversal as the item
end if;
end First_Actual;
+ ------------------
+ -- First_Global --
+ ------------------
+
+ function First_Global
+ (Subp : Entity_Id;
+ Global_Mode : Name_Id;
+ Refined : Boolean := False) return Node_Id
+ is
+ function First_From_Global_List
+ (List : Node_Id;
+ Global_Mode : Name_Id := Name_Input) return Entity_Id;
+ -- Get the first item with suitable mode from List
+
+ ----------------------------
+ -- First_From_Global_List --
+ ----------------------------
+
+ function First_From_Global_List
+ (List : Node_Id;
+ Global_Mode : Name_Id := Name_Input) return Entity_Id
+ is
+ Assoc : Node_Id;
+
+ begin
+ -- Empty list (no global items)
+
+ if Nkind (List) = N_Null then
+ return Empty;
+
+ -- Single global item declaration (only input items)
+
+ elsif Nkind_In (List, N_Expanded_Name,
+ N_Identifier,
+ N_Selected_Component)
+ then
+ if Global_Mode = Name_Input then
+ return List;
+ else
+ return Empty;
+ end if;
+
+ -- Simple global list (only input items) or moded global list
+ -- declaration.
+
+ elsif Nkind (List) = N_Aggregate then
+ if Present (Expressions (List)) then
+ if Global_Mode = Name_Input then
+ return First (Expressions (List));
+ else
+ return Empty;
+ end if;
+
+ else
+ Assoc := First (Component_Associations (List));
+ while Present (Assoc) loop
+
+ -- When we find the desired mode in an association, call
+ -- recursively First_From_Global_List as if the mode was
+ -- Name_Input, in order to reuse the existing machinery
+ -- for the other cases.
+
+ if Chars (First (Choices (Assoc))) = Global_Mode then
+ return First_From_Global_List (Expression (Assoc));
+ end if;
+
+ Next (Assoc);
+ end loop;
+
+ return Empty;
+ end if;
+
+ -- To accommodate partial decoration of disabled SPARK features,
+ -- this routine may be called with illegal input. If this is the
+ -- case, do not raise Program_Error.
+
+ else
+ return Empty;
+ end if;
+ end First_From_Global_List;
+
+ -- Local variables
+
+ Global : Node_Id := Empty;
+ Body_Id : Entity_Id;
+
+ begin
+ pragma Assert (Global_Mode = Name_Input
+ or else Global_Mode = Name_Output
+ or else Global_Mode = Name_In_Out
+ or else Global_Mode = Name_Proof_In);
+
+ -- Retrieve the suitable pragma Global or Refined_Global. In the second
+ -- case, it can only be located on the body entity.
+
+ if Refined then
+ Body_Id := Subprogram_Body_Entity (Subp);
+ if Present (Body_Id) then
+ Global := Get_Pragma (Body_Id, Pragma_Refined_Global);
+ end if;
+ else
+ Global := Get_Pragma (Subp, Pragma_Global);
+ end if;
+
+ -- No corresponding global if pragma is not present
+
+ if No (Global) then
+ return Empty;
+
+ -- Otherwise retrieve the corresponding list of items depending on the
+ -- Global_Mode.
+
+ else
+ return First_From_Global_List
+ (Expression (Get_Argument (Global, Subp)), Global_Mode);
+ end if;
+ end First_Global;
+
-------------
-- Fix_Msg --
-------------
end if;
Lit := First_Literal (Btyp);
+
+ -- Position in the enumeration type starts at 0
+
+ if UI_To_Int (Pos) < 0 then
+ raise Constraint_Error;
+ end if;
+
for J in 1 .. UI_To_Int (Pos) loop
Next_Literal (Lit);
-- Get_Task_Body_Procedure --
-----------------------------
- function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is
+ function Get_Task_Body_Procedure (E : Entity_Id) return Entity_Id is
begin
-- Note: A task type may be the completion of a private type with
-- discriminants. When performing elaboration checks on a task
and then Nkind (Node (First_Elmt (Constits))) /= N_Null;
end Has_Non_Null_Refinement;
+ -----------------------------
+ -- Has_Non_Null_Statements --
+ -----------------------------
+
+ function Has_Non_Null_Statements (L : List_Id) return Boolean is
+ Node : Node_Id;
+
+ begin
+ if Is_Non_Empty_List (L) then
+ Node := First (L);
+
+ loop
+ if Nkind (Node) /= N_Null_Statement then
+ return True;
+ end if;
+
+ Next (Node);
+ exit when Node = Empty;
+ end loop;
+ end if;
+
+ return False;
+ end Has_Non_Null_Statements;
+
----------------------------------
-- Has_Non_Trivial_Precondition --
----------------------------------
- function Has_Non_Trivial_Precondition (P : Entity_Id) return Boolean is
- Cont : constant Node_Id := Find_Aspect (P, Aspect_Pre);
+ function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean is
+ Pre : constant Node_Id := Find_Aspect (Subp, Aspect_Pre);
+
begin
- return Present (Cont)
- and then Class_Present (Cont)
- and then not Is_Entity_Name (Expression (Cont));
+ return
+ Present (Pre)
+ and then Class_Present (Pre)
+ and then not Is_Entity_Name (Expression (Pre));
end Has_Non_Trivial_Precondition;
-------------------
Ent : Entity_Id;
Exp : Node_Id;
- function Is_Preelaborable_Expression (N : Node_Id) return Boolean;
- -- Returns True if and only if the expression denoted by N does not
- -- violate restrictions on preelaborable constructs (RM-10.2.1(5-9)).
-
- ---------------------------------
- -- Is_Preelaborable_Expression --
- ---------------------------------
-
- function Is_Preelaborable_Expression (N : Node_Id) return Boolean is
- Exp : Node_Id;
- Assn : Node_Id;
- Choice : Node_Id;
- Comp_Type : Entity_Id;
- Is_Array_Aggr : Boolean;
-
- begin
- if Is_OK_Static_Expression (N) then
- return True;
-
- elsif Nkind (N) = N_Null then
- return True;
-
- -- Attributes are allowed in general, even if their prefix is a
- -- formal type. (It seems that certain attributes known not to be
- -- static might not be allowed, but there are no rules to prevent
- -- them.)
-
- elsif Nkind (N) = N_Attribute_Reference then
- return True;
-
- -- The name of a discriminant evaluated within its parent type is
- -- defined to be preelaborable (10.2.1(8)). Note that we test for
- -- names that denote discriminals as well as discriminants to
- -- catch references occurring within init procs.
-
- elsif Is_Entity_Name (N)
- and then
- (Ekind (Entity (N)) = E_Discriminant
- or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter)
- and then Present (Discriminal_Link (Entity (N)))))
- then
- return True;
-
- elsif Nkind (N) = N_Qualified_Expression then
- return Is_Preelaborable_Expression (Expression (N));
-
- -- For aggregates we have to check that each of the associations
- -- is preelaborable.
-
- elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
- Is_Array_Aggr := Is_Array_Type (Etype (N));
-
- if Is_Array_Aggr then
- Comp_Type := Component_Type (Etype (N));
- end if;
-
- -- Check the ancestor part of extension aggregates, which must
- -- be either the name of a type that has preelaborable init or
- -- an expression that is preelaborable.
-
- if Nkind (N) = N_Extension_Aggregate then
- declare
- Anc_Part : constant Node_Id := Ancestor_Part (N);
-
- begin
- if Is_Entity_Name (Anc_Part)
- and then Is_Type (Entity (Anc_Part))
- then
- if not Has_Preelaborable_Initialization
- (Entity (Anc_Part))
- then
- return False;
- end if;
-
- elsif not Is_Preelaborable_Expression (Anc_Part) then
- return False;
- end if;
- end;
- end if;
-
- -- Check positional associations
-
- Exp := First (Expressions (N));
- while Present (Exp) loop
- if not Is_Preelaborable_Expression (Exp) then
- return False;
- end if;
-
- Next (Exp);
- end loop;
-
- -- Check named associations
-
- Assn := First (Component_Associations (N));
- while Present (Assn) loop
- Choice := First (Choices (Assn));
- while Present (Choice) loop
- if Is_Array_Aggr then
- if Nkind (Choice) = N_Others_Choice then
- null;
-
- elsif Nkind (Choice) = N_Range then
- if not Is_OK_Static_Range (Choice) then
- return False;
- end if;
-
- elsif not Is_OK_Static_Expression (Choice) then
- return False;
- end if;
-
- else
- Comp_Type := Etype (Choice);
- end if;
-
- Next (Choice);
- end loop;
-
- -- If the association has a <> at this point, then we have
- -- to check whether the component's type has preelaborable
- -- initialization. Note that this only occurs when the
- -- association's corresponding component does not have a
- -- default expression, the latter case having already been
- -- expanded as an expression for the association.
-
- if Box_Present (Assn) then
- if not Has_Preelaborable_Initialization (Comp_Type) then
- return False;
- end if;
-
- -- In the expression case we check whether the expression
- -- is preelaborable.
-
- elsif
- not Is_Preelaborable_Expression (Expression (Assn))
- then
- return False;
- end if;
-
- Next (Assn);
- end loop;
-
- -- If we get here then aggregate as a whole is preelaborable
-
- return True;
-
- -- All other cases are not preelaborable
-
- else
- return False;
- end if;
- end Is_Preelaborable_Expression;
-
- -- Start of processing for Check_Components
-
begin
-- Loop through entities of record or protected type
-- Require the default expression to be preelaborable
- elsif not Is_Preelaborable_Expression (Exp) then
+ elsif not Is_Preelaborable_Construct (Exp) then
Has_PE := False;
exit;
end if;
-- In_Instance_Visible_Part --
------------------------------
- function In_Instance_Visible_Part return Boolean is
- S : Entity_Id;
+ function In_Instance_Visible_Part
+ (Id : Entity_Id := Current_Scope) return Boolean
+ is
+ Inst : Entity_Id;
begin
- S := Current_Scope;
- while Present (S) and then S /= Standard_Standard loop
- if Ekind (S) = E_Package
- and then Is_Generic_Instance (S)
- and then not In_Package_Body (S)
- and then not In_Private_Part (S)
+ Inst := Id;
+ while Present (Inst) and then Inst /= Standard_Standard loop
+ if Ekind (Inst) = E_Package
+ and then Is_Generic_Instance (Inst)
+ and then not In_Package_Body (Inst)
+ and then not In_Private_Part (Inst)
then
return True;
end if;
- S := Scope (S);
+ Inst := Scope (Inst);
end loop;
return False;
end loop;
end In_Subprogram_Or_Concurrent_Unit;
- ---------------------
- -- In_Visible_Part --
- ---------------------
+ ----------------
+ -- In_Subtree --
+ ----------------
+
+ function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean is
+ Curr : Node_Id;
- function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
begin
- return Is_Package_Or_Generic_Package (Scope_Id)
+ Curr := N;
+ while Present (Curr) loop
+ if Curr = Root then
+ return True;
+ end if;
+
+ Curr := Parent (Curr);
+ end loop;
+
+ return False;
+ end In_Subtree;
+
+ ----------------
+ -- In_Subtree --
+ ----------------
+
+ function In_Subtree
+ (N : Node_Id;
+ Root1 : Node_Id;
+ Root2 : Node_Id) return Boolean
+ is
+ Curr : Node_Id;
+
+ begin
+ Curr := N;
+ while Present (Curr) loop
+ if Curr = Root1 or else Curr = Root2 then
+ return True;
+ end if;
+
+ Curr := Parent (Curr);
+ end loop;
+
+ return False;
+ end In_Subtree;
+
+ ---------------------
+ -- In_Visible_Part --
+ ---------------------
+
+ function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
+ begin
+ return Is_Package_Or_Generic_Package (Scope_Id)
and then In_Open_Scopes (Scope_Id)
and then not In_Package_Body (Scope_Id)
and then not In_Private_Part (Scope_Id);
return Empty;
end Incomplete_Or_Partial_View;
+ ---------------------------------------
+ -- Incomplete_View_From_Limited_With --
+ ---------------------------------------
+
+ function Incomplete_View_From_Limited_With
+ (Typ : Entity_Id) return Entity_Id
+ is
+ begin
+ -- It might make sense to make this an attribute in Einfo, and set it
+ -- in Sem_Ch10 in Build_Shadow_Entity. However, we're running short on
+ -- slots for new attributes, and it seems a bit simpler to just search
+ -- the Limited_View (if it exists) for an incomplete type whose
+ -- Non_Limited_View is Typ.
+
+ if Ekind (Scope (Typ)) = E_Package
+ and then Present (Limited_View (Scope (Typ)))
+ then
+ declare
+ Ent : Entity_Id := First_Entity (Limited_View (Scope (Typ)));
+ begin
+ while Present (Ent) loop
+ if Ekind (Ent) in Incomplete_Kind
+ and then Non_Limited_View (Ent) = Typ
+ then
+ return Ent;
+ end if;
+
+ Ent := Next_Entity (Ent);
+ end loop;
+ end;
+ end if;
+
+ return Typ;
+ end Incomplete_View_From_Limited_With;
+
----------------------------------
-- Indexed_Component_Bit_Offset --
----------------------------------
or else (Present (Renamed_Object (E))
and then Is_Aliased_View (Renamed_Object (E)))))
- or else ((Is_Formal (E)
- or else Ekind_In (E, E_Generic_In_Out_Parameter,
- E_Generic_In_Parameter))
- and then Is_Tagged_Type (Etype (E)))
+ or else ((Is_Formal (E) or else Is_Formal_Object (E))
+ and then Is_Tagged_Type (Etype (E)))
or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E))
if Is_Single_Task_Object (Context_Id) then
return Scope_Within_Or_Same (Etype (Context_Id), Ref_Id);
- else
- pragma Assert
- (Is_Entry (Context_Id)
- or else
- Ekind_In (Context_Id, E_Function,
- E_Procedure,
- E_Task_Type));
+ else
+ pragma Assert (Ekind_In (Context_Id, E_Entry,
+ E_Entry_Family,
+ E_Function,
+ E_Package,
+ E_Procedure,
+ E_Protected_Type,
+ E_Task_Type)
+ or else
+ Is_Record_Type (Context_Id));
return Scope_Within_Or_Same (Context_Id, Ref_Id);
end if;
end Is_CCT_Instance;
function Is_Controlling_Limited_Procedure
(Proc_Nam : Entity_Id) return Boolean
is
+ Param : Node_Id;
Param_Typ : Entity_Id := Empty;
begin
if Ekind (Proc_Nam) = E_Procedure
and then Present (Parameter_Specifications (Parent (Proc_Nam)))
then
- Param_Typ := Etype (Parameter_Type (First (
- Parameter_Specifications (Parent (Proc_Nam)))));
+ Param :=
+ Parameter_Type
+ (First (Parameter_Specifications (Parent (Proc_Nam))));
- -- In this case where an Itype was created, the procedure call has been
- -- rewritten.
+ -- The formal may be an anonymous access type
+
+ if Nkind (Param) = N_Access_Definition then
+ Param_Typ := Entity (Subtype_Mark (Param));
+ else
+ Param_Typ := Etype (Param);
+ end if;
+
+ -- In the case where an Itype was created for a dispatchin call, the
+ -- procedure call has been rewritten. The actual may be an access to
+ -- interface type in which case it is the designated type that is the
+ -- controlling type.
elsif Present (Associated_Node_For_Itype (Proc_Nam))
and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam)))
Param_Typ :=
Etype (First (Parameter_Associations
(Associated_Node_For_Itype (Proc_Nam))));
+
+ if Ekind (Param_Typ) = E_Anonymous_Access_Type then
+ Param_Typ := Directly_Designated_Type (Param_Typ);
+ end if;
end if;
if Present (Param_Typ) then
end if;
-- A discriminant check on a selected component may be expanded
- -- into a dereference when removing side-effects. Recover the
+ -- into a dereference when removing side effects. Recover the
-- original node and its type, which may be unconstrained.
elsif Nkind (P) = N_Explicit_Dereference
end case;
end Is_Name_Reference;
+ ------------------------------------
+ -- Is_Non_Preelaborable_Construct --
+ ------------------------------------
+
+ function Is_Non_Preelaborable_Construct (N : Node_Id) return Boolean is
+
+ -- NOTE: the routines within Is_Non_Preelaborable_Construct are
+ -- intentionally unnested to avoid deep indentation of code.
+
+ Non_Preelaborable : exception;
+ -- This exception is raised when the construct violates preelaborability
+ -- to terminate the recursion.
+
+ procedure Visit (Nod : Node_Id);
+ -- Semantically inspect construct Nod to determine whether it violates
+ -- preelaborability. This routine raises Non_Preelaborable.
+
+ procedure Visit_List (List : List_Id);
+ pragma Inline (Visit_List);
+ -- Invoke Visit on each element of list List. This routine raises
+ -- Non_Preelaborable.
+
+ procedure Visit_Pragma (Prag : Node_Id);
+ pragma Inline (Visit_Pragma);
+ -- Semantically inspect pragma Prag to determine whether it violates
+ -- preelaborability. This routine raises Non_Preelaborable.
+
+ procedure Visit_Subexpression (Expr : Node_Id);
+ pragma Inline (Visit_Subexpression);
+ -- Semantically inspect expression Expr to determine whether it violates
+ -- preelaborability. This routine raises Non_Preelaborable.
+
+ -----------
+ -- Visit --
+ -----------
+
+ procedure Visit (Nod : Node_Id) is
+ begin
+ case Nkind (Nod) is
+
+ -- Declarations
+
+ when N_Component_Declaration =>
+
+ -- Defining_Identifier is left out because it is not relevant
+ -- for preelaborability.
+
+ Visit (Component_Definition (Nod));
+ Visit (Expression (Nod));
+
+ when N_Derived_Type_Definition =>
+
+ -- Interface_List is left out because it is not relevant for
+ -- preelaborability.
+
+ Visit (Record_Extension_Part (Nod));
+ Visit (Subtype_Indication (Nod));
+
+ when N_Entry_Declaration =>
+
+ -- A protected type with at leat one entry is not preelaborable
+ -- while task types are never preelaborable. This renders entry
+ -- declarations non-preelaborable.
+
+ raise Non_Preelaborable;
+
+ when N_Full_Type_Declaration =>
+
+ -- Defining_Identifier and Discriminant_Specifications are left
+ -- out because they are not relevant for preelaborability.
+
+ Visit (Type_Definition (Nod));
+
+ when N_Function_Instantiation
+ | N_Package_Instantiation
+ | N_Procedure_Instantiation
+ =>
+ -- Defining_Unit_Name and Name are left out because they are
+ -- not relevant for preelaborability.
+
+ Visit_List (Generic_Associations (Nod));
+
+ when N_Object_Declaration =>
+
+ -- Defining_Identifier is left out because it is not relevant
+ -- for preelaborability.
+
+ Visit (Object_Definition (Nod));
+
+ if Has_Init_Expression (Nod) then
+ Visit (Expression (Nod));
+
+ elsif not Has_Preelaborable_Initialization
+ (Etype (Defining_Entity (Nod)))
+ then
+ raise Non_Preelaborable;
+ end if;
+
+ when N_Private_Extension_Declaration
+ | N_Subtype_Declaration
+ =>
+ -- Defining_Identifier, Discriminant_Specifications, and
+ -- Interface_List are left out because they are not relevant
+ -- for preelaborability.
+
+ Visit (Subtype_Indication (Nod));
+
+ when N_Protected_Type_Declaration
+ | N_Single_Protected_Declaration
+ =>
+ -- Defining_Identifier, Discriminant_Specifications, and
+ -- Interface_List are left out because they are not relevant
+ -- for preelaborability.
+
+ Visit (Protected_Definition (Nod));
+
+ -- A [single] task type is never preelaborable
+
+ when N_Single_Task_Declaration
+ | N_Task_Type_Declaration
+ =>
+ raise Non_Preelaborable;
+
+ -- Pragmas
+
+ when N_Pragma =>
+ Visit_Pragma (Nod);
+
+ -- Statements
+
+ when N_Statement_Other_Than_Procedure_Call =>
+ if Nkind (Nod) /= N_Null_Statement then
+ raise Non_Preelaborable;
+ end if;
+
+ -- Subexpressions
+
+ when N_Subexpr =>
+ Visit_Subexpression (Nod);
+
+ -- Special
+
+ when N_Access_To_Object_Definition =>
+ Visit (Subtype_Indication (Nod));
+
+ when N_Case_Expression_Alternative =>
+ Visit (Expression (Nod));
+ Visit_List (Discrete_Choices (Nod));
+
+ when N_Component_Definition =>
+ Visit (Access_Definition (Nod));
+ Visit (Subtype_Indication (Nod));
+
+ when N_Component_List =>
+ Visit_List (Component_Items (Nod));
+ Visit (Variant_Part (Nod));
+
+ when N_Constrained_Array_Definition =>
+ Visit_List (Discrete_Subtype_Definitions (Nod));
+ Visit (Component_Definition (Nod));
+
+ when N_Delta_Constraint
+ | N_Digits_Constraint
+ =>
+ -- Delta_Expression and Digits_Expression are left out because
+ -- they are not relevant for preelaborability.
+
+ Visit (Range_Constraint (Nod));
+
+ when N_Discriminant_Specification =>
+
+ -- Defining_Identifier and Expression are left out because they
+ -- are not relevant for preelaborability.
+
+ Visit (Discriminant_Type (Nod));
+
+ when N_Generic_Association =>
+
+ -- Selector_Name is left out because it is not relevant for
+ -- preelaborability.
+
+ Visit (Explicit_Generic_Actual_Parameter (Nod));
+
+ when N_Index_Or_Discriminant_Constraint =>
+ Visit_List (Constraints (Nod));
+
+ when N_Iterator_Specification =>
+
+ -- Defining_Identifier is left out because it is not relevant
+ -- for preelaborability.
+
+ Visit (Name (Nod));
+ Visit (Subtype_Indication (Nod));
+
+ when N_Loop_Parameter_Specification =>
+
+ -- Defining_Identifier is left out because it is not relevant
+ -- for preelaborability.
+
+ Visit (Discrete_Subtype_Definition (Nod));
+
+ when N_Protected_Definition =>
+
+ -- End_Label is left out because it is not relevant for
+ -- preelaborability.
+
+ Visit_List (Private_Declarations (Nod));
+ Visit_List (Visible_Declarations (Nod));
+
+ when N_Range_Constraint =>
+ Visit (Range_Expression (Nod));
+
+ when N_Record_Definition
+ | N_Variant
+ =>
+ -- End_Label, Discrete_Choices, and Interface_List are left out
+ -- because they are not relevant for preelaborability.
+
+ Visit (Component_List (Nod));
+
+ when N_Subtype_Indication =>
+
+ -- Subtype_Mark is left out because it is not relevant for
+ -- preelaborability.
+
+ Visit (Constraint (Nod));
+
+ when N_Unconstrained_Array_Definition =>
+
+ -- Subtype_Marks is left out because it is not relevant for
+ -- preelaborability.
+
+ Visit (Component_Definition (Nod));
+
+ when N_Variant_Part =>
+
+ -- Name is left out because it is not relevant for
+ -- preelaborability.
+
+ Visit_List (Variants (Nod));
+
+ -- Default
+
+ when others =>
+ null;
+ end case;
+ end Visit;
+
+ ----------------
+ -- Visit_List --
+ ----------------
+
+ procedure Visit_List (List : List_Id) is
+ Nod : Node_Id;
+
+ begin
+ if Present (List) then
+ Nod := First (List);
+ while Present (Nod) loop
+ Visit (Nod);
+ Next (Nod);
+ end loop;
+ end if;
+ end Visit_List;
+
+ ------------------
+ -- Visit_Pragma --
+ ------------------
+
+ procedure Visit_Pragma (Prag : Node_Id) is
+ begin
+ case Get_Pragma_Id (Prag) is
+ when Pragma_Assert
+ | Pragma_Assert_And_Cut
+ | Pragma_Assume
+ | Pragma_Async_Readers
+ | Pragma_Async_Writers
+ | Pragma_Attribute_Definition
+ | Pragma_Check
+ | Pragma_Constant_After_Elaboration
+ | Pragma_CPU
+ | Pragma_Deadline_Floor
+ | Pragma_Dispatching_Domain
+ | Pragma_Effective_Reads
+ | Pragma_Effective_Writes
+ | Pragma_Extensions_Visible
+ | Pragma_Ghost
+ | Pragma_Secondary_Stack_Size
+ | Pragma_Task_Name
+ | Pragma_Volatile_Function
+ =>
+ Visit_List (Pragma_Argument_Associations (Prag));
+
+ -- Default
+
+ when others =>
+ null;
+ end case;
+ end Visit_Pragma;
+
+ -------------------------
+ -- Visit_Subexpression --
+ -------------------------
+
+ procedure Visit_Subexpression (Expr : Node_Id) is
+ procedure Visit_Aggregate (Aggr : Node_Id);
+ pragma Inline (Visit_Aggregate);
+ -- Semantically inspect aggregate Aggr to determine whether it
+ -- violates preelaborability.
+
+ ---------------------
+ -- Visit_Aggregate --
+ ---------------------
+
+ procedure Visit_Aggregate (Aggr : Node_Id) is
+ begin
+ if not Is_Preelaborable_Aggregate (Aggr) then
+ raise Non_Preelaborable;
+ end if;
+ end Visit_Aggregate;
+
+ -- Start of processing for Visit_Subexpression
+
+ begin
+ case Nkind (Expr) is
+ when N_Allocator
+ | N_Qualified_Expression
+ | N_Type_Conversion
+ | N_Unchecked_Expression
+ | N_Unchecked_Type_Conversion
+ =>
+ -- Subpool_Handle_Name and Subtype_Mark are left out because
+ -- they are not relevant for preelaborability.
+
+ Visit (Expression (Expr));
+
+ when N_Aggregate
+ | N_Extension_Aggregate
+ =>
+ Visit_Aggregate (Expr);
+
+ when N_Attribute_Reference
+ | N_Explicit_Dereference
+ | N_Reference
+ =>
+ -- Attribute_Name and Expressions are left out because they are
+ -- not relevant for preelaborability.
+
+ Visit (Prefix (Expr));
+
+ when N_Case_Expression =>
+
+ -- End_Span is left out because it is not relevant for
+ -- preelaborability.
+
+ Visit_List (Alternatives (Expr));
+ Visit (Expression (Expr));
+
+ when N_Delta_Aggregate =>
+ Visit_Aggregate (Expr);
+ Visit (Expression (Expr));
+
+ when N_Expression_With_Actions =>
+ Visit_List (Actions (Expr));
+ Visit (Expression (Expr));
+
+ when N_If_Expression =>
+ Visit_List (Expressions (Expr));
+
+ when N_Quantified_Expression =>
+ Visit (Condition (Expr));
+ Visit (Iterator_Specification (Expr));
+ Visit (Loop_Parameter_Specification (Expr));
+
+ when N_Range =>
+ Visit (High_Bound (Expr));
+ Visit (Low_Bound (Expr));
+
+ when N_Slice =>
+ Visit (Discrete_Range (Expr));
+ Visit (Prefix (Expr));
+
+ -- Default
+
+ when others =>
+
+ -- The evaluation of an object name is not preelaborable,
+ -- unless the name is a static expression (checked further
+ -- below), or statically denotes a discriminant.
+
+ if Is_Entity_Name (Expr) then
+ Object_Name : declare
+ Id : constant Entity_Id := Entity (Expr);
+
+ begin
+ if Is_Object (Id) then
+ if Ekind (Id) = E_Discriminant then
+ null;
+
+ elsif Ekind_In (Id, E_Constant, E_In_Parameter)
+ and then Present (Discriminal_Link (Id))
+ then
+ null;
+
+ else
+ raise Non_Preelaborable;
+ end if;
+ end if;
+ end Object_Name;
+
+ -- A non-static expression is not preelaborable
+
+ elsif not Is_OK_Static_Expression (Expr) then
+ raise Non_Preelaborable;
+ end if;
+ end case;
+ end Visit_Subexpression;
+
+ -- Start of processing for Is_Non_Preelaborable_Construct
+
+ begin
+ Visit (N);
+
+ -- At this point it is known that the construct is preelaborable
+
+ return False;
+
+ exception
+
+ -- The elaboration of the construct performs an action which violates
+ -- preelaborability.
+
+ when Non_Preelaborable =>
+ return True;
+ end Is_Non_Preelaborable_Construct;
+
---------------------------------
-- Is_Nontrivial_DIC_Procedure --
---------------------------------
function Within_Check (Nod : Node_Id) return Boolean;
-- Determine whether an arbitrary node appears in a check node
- function Within_Subprogram_Call (Nod : Node_Id) return Boolean;
- -- Determine whether an arbitrary node appears in an entry, function, or
- -- procedure call.
-
function Within_Volatile_Function (Id : Entity_Id) return Boolean;
-- Determine whether an arbitrary entity appears in a volatile function
return False;
end Within_Check;
- ----------------------------
- -- Within_Subprogram_Call --
- ----------------------------
-
- function Within_Subprogram_Call (Nod : Node_Id) return Boolean is
- Par : Node_Id;
-
- begin
- -- Climb the parent chain looking for a function or procedure call
-
- Par := Nod;
- while Present (Par) loop
- if Nkind_In (Par, N_Entry_Call_Statement,
- N_Function_Call,
- N_Procedure_Call_Statement)
- then
- return True;
-
- -- Prevent the search from going too far
-
- elsif Is_Body_Or_Package_Declaration (Par) then
- exit;
- end if;
-
- Par := Parent (Par);
- end loop;
-
- return False;
- end Within_Subprogram_Call;
-
------------------------------
-- Within_Volatile_Function --
------------------------------
end if;
end Is_Potentially_Unevaluated;
- ---------------------------------
+ --------------------------------
+ -- Is_Preelaborable_Aggregate --
+ --------------------------------
+
+ function Is_Preelaborable_Aggregate (Aggr : Node_Id) return Boolean is
+ Aggr_Typ : constant Entity_Id := Etype (Aggr);
+ Array_Aggr : constant Boolean := Is_Array_Type (Aggr_Typ);
+
+ Anc_Part : Node_Id;
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Comp_Typ : Entity_Id := Empty; -- init to avoid warning
+ Expr : Node_Id;
+
+ begin
+ if Array_Aggr then
+ Comp_Typ := Component_Type (Aggr_Typ);
+ end if;
+
+ -- Inspect the ancestor part
+
+ if Nkind (Aggr) = N_Extension_Aggregate then
+ Anc_Part := Ancestor_Part (Aggr);
+
+ -- The ancestor denotes a subtype mark
+
+ if Is_Entity_Name (Anc_Part)
+ and then Is_Type (Entity (Anc_Part))
+ then
+ if not Has_Preelaborable_Initialization (Entity (Anc_Part)) then
+ return False;
+ end if;
+
+ -- Otherwise the ancestor denotes an expression
+
+ elsif not Is_Preelaborable_Construct (Anc_Part) then
+ return False;
+ end if;
+ end if;
+
+ -- Inspect the positional associations
+
+ Expr := First (Expressions (Aggr));
+ while Present (Expr) loop
+ if not Is_Preelaborable_Construct (Expr) then
+ return False;
+ end if;
+
+ Next (Expr);
+ end loop;
+
+ -- Inspect the named associations
+
+ Assoc := First (Component_Associations (Aggr));
+ while Present (Assoc) loop
+
+ -- Inspect the choices of the current named association
+
+ Choice := First (Choices (Assoc));
+ while Present (Choice) loop
+ if Array_Aggr then
+
+ -- For a choice to be preelaborable, it must denote either a
+ -- static range or a static expression.
+
+ if Nkind (Choice) = N_Others_Choice then
+ null;
+
+ elsif Nkind (Choice) = N_Range then
+ if not Is_OK_Static_Range (Choice) then
+ return False;
+ end if;
+
+ elsif not Is_OK_Static_Expression (Choice) then
+ return False;
+ end if;
+
+ else
+ Comp_Typ := Etype (Choice);
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ -- The type of the choice must have preelaborable initialization if
+ -- the association carries a <>.
+
+ pragma Assert (Present (Comp_Typ));
+ if Box_Present (Assoc) then
+ if not Has_Preelaborable_Initialization (Comp_Typ) then
+ return False;
+ end if;
+
+ -- The type of the expression must have preelaborable initialization
+
+ elsif not Is_Preelaborable_Construct (Expression (Assoc)) then
+ return False;
+ end if;
+
+ Next (Assoc);
+ end loop;
+
+ -- At this point the aggregate is preelaborable
+
+ return True;
+ end Is_Preelaborable_Aggregate;
+
+ --------------------------------
+ -- Is_Preelaborable_Construct --
+ --------------------------------
+
+ function Is_Preelaborable_Construct (N : Node_Id) return Boolean is
+ begin
+ -- Aggregates
+
+ if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
+ return Is_Preelaborable_Aggregate (N);
+
+ -- Attributes are allowed in general, even if their prefix is a formal
+ -- type. It seems that certain attributes known not to be static might
+ -- not be allowed, but there are no rules to prevent them.
+
+ elsif Nkind (N) = N_Attribute_Reference then
+ return True;
+
+ -- Expressions
+
+ elsif Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then
+ return True;
+
+ elsif Nkind (N) = N_Qualified_Expression then
+ return Is_Preelaborable_Construct (Expression (N));
+
+ -- Names are preelaborable when they denote a discriminant of an
+ -- enclosing type. Discriminals are also considered for this check.
+
+ elsif Is_Entity_Name (N)
+ and then Present (Entity (N))
+ and then
+ (Ekind (Entity (N)) = E_Discriminant
+ or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter)
+ and then Present (Discriminal_Link (Entity (N)))))
+ then
+ return True;
+
+ -- Statements
+
+ elsif Nkind (N) = N_Null then
+ return True;
+
+ -- Otherwise the construct is not preelaborable
+
+ else
+ return False;
+ end if;
+ end Is_Preelaborable_Construct;
+
+ ---------------------------------
-- Is_Protected_Self_Reference --
---------------------------------
end if;
end Is_Volatile_Object;
+ -----------------------------
+ -- Iterate_Call_Parameters --
+ -----------------------------
+
+ procedure Iterate_Call_Parameters (Call : Node_Id) is
+ Formal : Entity_Id := First_Formal (Get_Called_Entity (Call));
+ Actual : Node_Id := First_Actual (Call);
+
+ begin
+ while Present (Formal) and then Present (Actual) loop
+ Handle_Parameter (Formal, Actual);
+ Formal := Next_Formal (Formal);
+ Actual := Next_Actual (Actual);
+ end loop;
+ end Iterate_Call_Parameters;
+
---------------------------
-- Itype_Has_Declaration --
---------------------------
return N;
end Last_Source_Statement;
- ----------------------------------
- -- Matching_Static_Array_Bounds --
- ----------------------------------
-
- function Matching_Static_Array_Bounds
- (L_Typ : Node_Id;
- R_Typ : Node_Id) return Boolean
- is
- L_Ndims : constant Nat := Number_Dimensions (L_Typ);
- R_Ndims : constant Nat := Number_Dimensions (R_Typ);
-
- L_Index : Node_Id;
- R_Index : Node_Id;
- L_Low : Node_Id;
- L_High : Node_Id;
- L_Len : Uint;
- R_Low : Node_Id;
- R_High : Node_Id;
- R_Len : Uint;
+ -----------------------
+ -- Mark_Coextensions --
+ -----------------------
- begin
- if L_Ndims /= R_Ndims then
- return False;
- end if;
+ procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
+ Is_Dynamic : Boolean;
+ -- Indicates whether the context causes nested coextensions to be
+ -- dynamic or static
- -- Unconstrained types do not have static bounds
+ function Mark_Allocator (N : Node_Id) return Traverse_Result;
+ -- Recognize an allocator node and label it as a dynamic coextension
- if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then
- return False;
- end if;
+ --------------------
+ -- Mark_Allocator --
+ --------------------
- -- First treat specially the first dimension, as the lower bound and
- -- length of string literals are not stored like those of arrays.
+ function Mark_Allocator (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Allocator then
+ if Is_Dynamic then
+ Set_Is_Dynamic_Coextension (N);
- if Ekind (L_Typ) = E_String_Literal_Subtype then
- L_Low := String_Literal_Low_Bound (L_Typ);
- L_Len := String_Literal_Length (L_Typ);
- else
- L_Index := First_Index (L_Typ);
- Get_Index_Bounds (L_Index, L_Low, L_High);
+ -- 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 ???
- if Is_OK_Static_Expression (L_Low)
- and then
- Is_OK_Static_Expression (L_High)
- then
- if Expr_Value (L_High) < Expr_Value (L_Low) then
- L_Len := Uint_0;
+ elsif Nkind (Expression (N)) = N_Qualified_Expression
+ and then Nkind (Expression (Expression (N))) = N_Op_Concat
+ then
+ Set_Is_Dynamic_Coextension (N);
else
- L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1;
+ Set_Is_Static_Coextension (N);
end if;
- else
- return False;
end if;
- end if;
- if Ekind (R_Typ) = E_String_Literal_Subtype then
- R_Low := String_Literal_Low_Bound (R_Typ);
- R_Len := String_Literal_Length (R_Typ);
- else
- R_Index := First_Index (R_Typ);
- Get_Index_Bounds (R_Index, R_Low, R_High);
+ return OK;
+ end Mark_Allocator;
- if Is_OK_Static_Expression (R_Low)
- and then
- Is_OK_Static_Expression (R_High)
- then
- if Expr_Value (R_High) < Expr_Value (R_Low) then
- R_Len := Uint_0;
- else
- R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1;
- end if;
- else
- return False;
- end if;
- end if;
+ procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
- if (Is_OK_Static_Expression (L_Low)
- and then
- Is_OK_Static_Expression (R_Low))
- and then Expr_Value (L_Low) = Expr_Value (R_Low)
- and then L_Len = R_Len
- then
- null;
- else
- return False;
- end if;
+ -- Start of processing for Mark_Coextensions
- -- Then treat all other dimensions
+ begin
+ -- An allocator that appears on the right-hand side of an assignment is
+ -- treated as a potentially dynamic coextension when the right-hand side
+ -- is an allocator or a qualified expression.
- for Indx in 2 .. L_Ndims loop
- Next (L_Index);
- Next (R_Index);
+ -- Obj := new ...'(new Coextension ...);
- Get_Index_Bounds (L_Index, L_Low, L_High);
- Get_Index_Bounds (R_Index, R_Low, R_High);
+ if Nkind (Context_Nod) = N_Assignment_Statement then
+ Is_Dynamic :=
+ Nkind_In (Expression (Context_Nod), N_Allocator,
+ N_Qualified_Expression);
- if (Is_OK_Static_Expression (L_Low) and then
- Is_OK_Static_Expression (L_High) and then
- Is_OK_Static_Expression (R_Low) and then
- Is_OK_Static_Expression (R_High))
- and then (Expr_Value (L_Low) = Expr_Value (R_Low)
- and then
- Expr_Value (L_High) = Expr_Value (R_High))
- then
- null;
- else
- return False;
- end if;
- end loop;
+ -- An allocator that appears within the expression of a simple return
+ -- statement is treated as a potentially dynamic coextension when the
+ -- expression is either aggregate, allocator, or qualified expression.
- -- If we fall through the loop, all indexes matched
+ -- return (new Coextension ...);
+ -- return new ...'(new Coextension ...);
- return True;
- end Matching_Static_Array_Bounds;
+ elsif Nkind (Context_Nod) = N_Simple_Return_Statement then
+ Is_Dynamic :=
+ Nkind_In (Expression (Context_Nod), N_Aggregate,
+ N_Allocator,
+ N_Qualified_Expression);
- -------------------
- -- May_Be_Lvalue --
- -------------------
+ -- An alloctor that appears within the initialization expression of an
+ -- object declaration is considered a potentially dynamic coextension
+ -- when the initialization expression is an allocator or a qualified
+ -- expression.
- function May_Be_Lvalue (N : Node_Id) return Boolean is
- P : constant Node_Id := Parent (N);
+ -- Obj : ... := new ...'(new Coextension ...);
- begin
- case Nkind (P) is
+ -- A similar case arises when the object declaration is part of an
+ -- extended return statement.
- -- Test left side of assignment
+ -- return Obj : ... := new ...'(new Coextension ...);
+ -- return Obj : ... := (new Coextension ...);
+
+ elsif Nkind (Context_Nod) = N_Object_Declaration then
+ Is_Dynamic :=
+ Nkind_In (Root_Nod, N_Allocator, N_Qualified_Expression)
+ or else
+ Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement;
+
+ -- This routine should not be called with constructs that cannot contain
+ -- coextensions.
+
+ else
+ raise Program_Error;
+ end if;
+
+ Mark_Allocators (Root_Nod);
+ end Mark_Coextensions;
+
+ ---------------------------------
+ -- Mark_Elaboration_Attributes --
+ ---------------------------------
+
+ procedure Mark_Elaboration_Attributes
+ (N_Id : Node_Or_Entity_Id;
+ Checks : Boolean := False;
+ Level : Boolean := False;
+ Modes : Boolean := False;
+ Warnings : Boolean := False)
+ is
+ function Elaboration_Checks_OK
+ (Target_Id : Entity_Id;
+ Context_Id : Entity_Id) return Boolean;
+ -- Determine whether elaboration checks are enabled for target Target_Id
+ -- which resides within context Context_Id.
+
+ procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id);
+ -- Preserve relevant attributes of the context in arbitrary entity Id
+
+ procedure Mark_Elaboration_Attributes_Node (N : Node_Id);
+ -- Preserve relevant attributes of the context in arbitrary node N
+
+ ---------------------------
+ -- Elaboration_Checks_OK --
+ ---------------------------
+
+ function Elaboration_Checks_OK
+ (Target_Id : Entity_Id;
+ Context_Id : Entity_Id) return Boolean
+ is
+ Encl_Scop : Entity_Id;
+
+ begin
+ -- Elaboration checks are suppressed for the target
+
+ if Elaboration_Checks_Suppressed (Target_Id) then
+ return False;
+ end if;
+
+ -- Otherwise elaboration checks are OK for the target, but may be
+ -- suppressed for the context where the target is declared.
+
+ Encl_Scop := Context_Id;
+ while Present (Encl_Scop) and then Encl_Scop /= Standard_Standard loop
+ if Elaboration_Checks_Suppressed (Encl_Scop) then
+ return False;
+ end if;
+
+ Encl_Scop := Scope (Encl_Scop);
+ end loop;
+
+ -- Neither the target nor its declarative context have elaboration
+ -- checks suppressed.
+
+ return True;
+ end Elaboration_Checks_OK;
+
+ ------------------------------------
+ -- Mark_Elaboration_Attributes_Id --
+ ------------------------------------
+
+ procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id) is
+ begin
+ -- Mark the status of elaboration checks in effect. Do not reset the
+ -- status in case the entity is reanalyzed with checks suppressed.
+
+ if Checks and then not Is_Elaboration_Checks_OK_Id (Id) then
+ Set_Is_Elaboration_Checks_OK_Id (Id,
+ Elaboration_Checks_OK
+ (Target_Id => Id,
+ Context_Id => Scope (Id)));
+
+ -- Entities do not need to capture their enclosing level. The Ghost
+ -- and SPARK modes in effect are already marked during analysis.
+
+ else
+ null;
+ end if;
+ end Mark_Elaboration_Attributes_Id;
+
+ --------------------------------------
+ -- Mark_Elaboration_Attributes_Node --
+ --------------------------------------
+
+ procedure Mark_Elaboration_Attributes_Node (N : Node_Id) is
+ function Extract_Name (N : Node_Id) return Node_Id;
+ -- Obtain the Name attribute of call or instantiation N
+
+ ------------------
+ -- Extract_Name --
+ ------------------
+
+ function Extract_Name (N : Node_Id) return Node_Id is
+ Nam : Node_Id;
+
+ begin
+ Nam := Name (N);
+
+ -- A call to an entry family appears in indexed form
+
+ if Nkind (Nam) = N_Indexed_Component then
+ Nam := Prefix (Nam);
+ end if;
+
+ -- The name may also appear in qualified form
+
+ if Nkind (Nam) = N_Selected_Component then
+ Nam := Selector_Name (Nam);
+ end if;
+
+ return Nam;
+ end Extract_Name;
+
+ -- Local variables
+
+ Context_Id : Entity_Id;
+ Nam : Node_Id;
+
+ -- Start of processing for Mark_Elaboration_Attributes_Node
+
+ begin
+ -- Mark the status of elaboration checks in effect. Do not reset the
+ -- status in case the node is reanalyzed with checks suppressed.
+
+ if Checks and then not Is_Elaboration_Checks_OK_Node (N) then
+
+ -- Assignments, attribute references, and variable references do
+ -- not have a "declarative" context.
+
+ Context_Id := Empty;
+
+ -- The status of elaboration checks for calls and instantiations
+ -- depends on the most recent pragma Suppress/Unsuppress, as well
+ -- as the suppression status of the context where the target is
+ -- defined.
+
+ -- package Pack is
+ -- function Func ...;
+ -- end Pack;
+
+ -- with Pack;
+ -- procedure Main is
+ -- pragma Suppress (Elaboration_Checks, Pack);
+ -- X : ... := Pack.Func;
+ -- ...
+
+ -- In the example above, the call to Func has elaboration checks
+ -- enabled because there is no active general purpose suppression
+ -- pragma, however the elaboration checks of Pack are explicitly
+ -- suppressed. As a result the elaboration checks of the call must
+ -- be disabled in order to preserve this dependency.
+
+ if Nkind_In (N, N_Entry_Call_Statement,
+ N_Function_Call,
+ N_Function_Instantiation,
+ N_Package_Instantiation,
+ N_Procedure_Call_Statement,
+ N_Procedure_Instantiation)
+ then
+ Nam := Extract_Name (N);
+
+ if Is_Entity_Name (Nam) and then Present (Entity (Nam)) then
+ Context_Id := Scope (Entity (Nam));
+ end if;
+ end if;
+
+ Set_Is_Elaboration_Checks_OK_Node (N,
+ Elaboration_Checks_OK
+ (Target_Id => Empty,
+ Context_Id => Context_Id));
+ end if;
+
+ -- Mark the enclosing level of the node. Do not reset the status in
+ -- case the node is relocated and reanalyzed.
+
+ if Level and then not Is_Declaration_Level_Node (N) then
+ Set_Is_Declaration_Level_Node (N,
+ Find_Enclosing_Level (N) = Declaration_Level);
+ end if;
+
+ -- Mark the Ghost and SPARK mode in effect
+
+ if Modes then
+ if Ghost_Mode = Ignore then
+ Set_Is_Ignored_Ghost_Node (N);
+ end if;
+
+ if SPARK_Mode = On then
+ Set_Is_SPARK_Mode_On_Node (N);
+ end if;
+ end if;
+
+ -- Mark the status of elaboration warnings in effect. Do not reset
+ -- the status in case the node is reanalyzed with warnings off.
+
+ if Warnings and then not Is_Elaboration_Warnings_OK_Node (N) then
+ Set_Is_Elaboration_Warnings_OK_Node (N, Elab_Warnings);
+ end if;
+ end Mark_Elaboration_Attributes_Node;
+
+ -- Start of processing for Mark_Elaboration_Attributes
+
+ begin
+ -- Do not capture any elaboration-related attributes when switch -gnatH
+ -- (legacy elaboration checking mode enabled) is in effect because the
+ -- attributes are useless to the legacy model.
+
+ if Legacy_Elaboration_Checks then
+ return;
+ end if;
+
+ if Nkind (N_Id) in N_Entity then
+ Mark_Elaboration_Attributes_Id (N_Id);
+ else
+ Mark_Elaboration_Attributes_Node (N_Id);
+ end if;
+ end Mark_Elaboration_Attributes;
+
+ ----------------------------------
+ -- Matching_Static_Array_Bounds --
+ ----------------------------------
+
+ function Matching_Static_Array_Bounds
+ (L_Typ : Node_Id;
+ R_Typ : Node_Id) return Boolean
+ is
+ L_Ndims : constant Nat := Number_Dimensions (L_Typ);
+ R_Ndims : constant Nat := Number_Dimensions (R_Typ);
+
+ L_Index : Node_Id := Empty; -- init to ...
+ R_Index : Node_Id := Empty; -- ...avoid warnings
+ L_Low : Node_Id;
+ L_High : Node_Id;
+ L_Len : Uint;
+ R_Low : Node_Id;
+ R_High : Node_Id;
+ R_Len : Uint;
+
+ begin
+ if L_Ndims /= R_Ndims then
+ return False;
+ end if;
+
+ -- Unconstrained types do not have static bounds
+
+ if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then
+ return False;
+ end if;
+
+ -- First treat specially the first dimension, as the lower bound and
+ -- length of string literals are not stored like those of arrays.
+
+ if Ekind (L_Typ) = E_String_Literal_Subtype then
+ L_Low := String_Literal_Low_Bound (L_Typ);
+ L_Len := String_Literal_Length (L_Typ);
+ else
+ L_Index := First_Index (L_Typ);
+ Get_Index_Bounds (L_Index, L_Low, L_High);
+
+ if Is_OK_Static_Expression (L_Low)
+ and then
+ Is_OK_Static_Expression (L_High)
+ then
+ if Expr_Value (L_High) < Expr_Value (L_Low) then
+ L_Len := Uint_0;
+ else
+ L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1;
+ end if;
+ else
+ return False;
+ end if;
+ end if;
+
+ if Ekind (R_Typ) = E_String_Literal_Subtype then
+ R_Low := String_Literal_Low_Bound (R_Typ);
+ R_Len := String_Literal_Length (R_Typ);
+ else
+ R_Index := First_Index (R_Typ);
+ Get_Index_Bounds (R_Index, R_Low, R_High);
+
+ if Is_OK_Static_Expression (R_Low)
+ and then
+ Is_OK_Static_Expression (R_High)
+ then
+ if Expr_Value (R_High) < Expr_Value (R_Low) then
+ R_Len := Uint_0;
+ else
+ R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1;
+ end if;
+ else
+ return False;
+ end if;
+ end if;
+
+ if (Is_OK_Static_Expression (L_Low)
+ and then
+ Is_OK_Static_Expression (R_Low))
+ and then Expr_Value (L_Low) = Expr_Value (R_Low)
+ and then L_Len = R_Len
+ then
+ null;
+ else
+ return False;
+ end if;
+
+ -- Then treat all other dimensions
+
+ for Indx in 2 .. L_Ndims loop
+ Next (L_Index);
+ Next (R_Index);
+
+ Get_Index_Bounds (L_Index, L_Low, L_High);
+ Get_Index_Bounds (R_Index, R_Low, R_High);
+
+ if (Is_OK_Static_Expression (L_Low) and then
+ Is_OK_Static_Expression (L_High) and then
+ Is_OK_Static_Expression (R_Low) and then
+ Is_OK_Static_Expression (R_High))
+ and then (Expr_Value (L_Low) = Expr_Value (R_Low)
+ and then
+ Expr_Value (L_High) = Expr_Value (R_High))
+ then
+ null;
+ else
+ return False;
+ end if;
+ end loop;
+
+ -- If we fall through the loop, all indexes matched
+
+ return True;
+ end Matching_Static_Array_Bounds;
+
+ -------------------
+ -- May_Be_Lvalue --
+ -------------------
+
+ function May_Be_Lvalue (N : Node_Id) return Boolean is
+ P : constant Node_Id := Parent (N);
+
+ begin
+ case Nkind (P) is
+
+ -- Test left side of assignment
when N_Assignment_Statement =>
return N = Name (P);
end case;
end May_Be_Lvalue;
- -----------------------
- -- Mark_Coextensions --
- -----------------------
+ -----------------
+ -- Might_Raise --
+ -----------------
- procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
- Is_Dynamic : Boolean;
- -- Indicates whether the context causes nested coextensions to be
- -- dynamic or static
+ function Might_Raise (N : Node_Id) return Boolean is
+ Result : Boolean := False;
- function Mark_Allocator (N : Node_Id) return Traverse_Result;
- -- Recognize an allocator node and label it as a dynamic coextension
+ function Process (N : Node_Id) return Traverse_Result;
+ -- Set Result to True if we find something that could raise an exception
- --------------------
- -- Mark_Allocator --
- --------------------
+ -------------
+ -- Process --
+ -------------
- function Mark_Allocator (N : Node_Id) return Traverse_Result is
- begin
- 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;
- end if;
-
- return OK;
- end Mark_Allocator;
-
- procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
-
- -- Start of processing for Mark_Coextensions
-
- begin
- -- An allocator that appears on the right-hand side of an assignment is
- -- treated as a potentially dynamic coextension when the right-hand side
- -- is an allocator or a qualified expression.
-
- -- Obj := new ...'(new Coextension ...);
-
- if Nkind (Context_Nod) = N_Assignment_Statement then
- Is_Dynamic :=
- Nkind_In (Expression (Context_Nod), N_Allocator,
- N_Qualified_Expression);
-
- -- An allocator that appears within the expression of a simple return
- -- statement is treated as a potentially dynamic coextension when the
- -- expression is either aggregate, allocator, or qualified expression.
-
- -- return (new Coextension ...);
- -- return new ...'(new Coextension ...);
-
- elsif Nkind (Context_Nod) = N_Simple_Return_Statement then
- Is_Dynamic :=
- Nkind_In (Expression (Context_Nod), N_Aggregate,
- N_Allocator,
- N_Qualified_Expression);
-
- -- An allocator that appears within the initialization expression of an
- -- object declaration is considered a potentially dynamic coextension
- -- when the initialization expression is an allocator or a qualified
- -- expression.
-
- -- Obj : ... := new ...'(new Coextension ...);
-
- -- A similar case arises when the object declaration is part of an
- -- extended return statement.
-
- -- return Obj : ... := new ...'(new Coextension ...);
- -- return Obj : ... := (new Coextension ...);
-
- elsif Nkind (Context_Nod) = N_Object_Declaration then
- Is_Dynamic :=
- Nkind_In (Root_Nod, N_Allocator, N_Qualified_Expression)
- or else
- Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement;
-
- -- This routine should not be called with constructs that cannot contain
- -- coextensions.
-
- else
- raise Program_Error;
- end if;
-
- Mark_Allocators (Root_Nod);
- end Mark_Coextensions;
-
- -----------------
- -- Might_Raise --
- -----------------
-
- function Might_Raise (N : Node_Id) return Boolean is
- Result : Boolean := False;
-
- function Process (N : Node_Id) return Traverse_Result;
- -- Set Result to True if we find something that could raise an exception
-
- -------------
- -- Process --
- -------------
-
- function Process (N : Node_Id) return Traverse_Result is
+ function Process (N : Node_Id) return Traverse_Result is
begin
if Nkind_In (N, N_Procedure_Call_Statement,
N_Function_Call,
end if;
end New_Copy_List_Tree;
- --------------------------------------------------
- -- New_Copy_Tree Auxiliary Data and Subprograms --
- --------------------------------------------------
-
- use Atree.Unchecked_Access;
- use Atree_Private_Part;
+ -------------------
+ -- New_Copy_Tree --
+ -------------------
- -- 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 tables play a key role in replicating entities and Itypes.
+ -- They are intentionally declared at the library level rather than within
+ -- New_Copy_Tree to avoid elaborating them on each call. This performance
+ -- optimization saves up to 2% of the entire compilation time spent in the
+ -- front end. Care should be taken to reset the tables on each new call to
+ -- New_Copy_Tree.
- -- The following hash tables are used to speed up access to the map. They
- -- are declared at library level to avoid elaborating them for every call
- -- to New_Copy_Tree. This can save up to 2% of the entire compilation time
- -- spent in the front end.
+ NCT_Table_Max : constant := 511;
- subtype NCT_Header_Num is Int range 0 .. 511;
- -- Defines range of headers in hash tables (512 headers)
+ subtype NCT_Table_Index is Nat range 0 .. NCT_Table_Max - 1;
- function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
- -- Hash function used for hash operations
+ function NCT_Table_Hash (Key : Node_Or_Entity_Id) return NCT_Table_Index;
+ -- Obtain the hash value of node or entity Key
- -------------------
- -- New_Copy_Hash --
- -------------------
+ --------------------
+ -- NCT_Table_Hash --
+ --------------------
- function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
+ function NCT_Table_Hash (Key : Node_Or_Entity_Id) return NCT_Table_Index is
begin
- return Nat (E) mod (NCT_Header_Num'Last + 1);
- end New_Copy_Hash;
+ return NCT_Table_Index (Key mod NCT_Table_Max);
+ end NCT_Table_Hash;
- ---------------
- -- NCT_Assoc --
- ---------------
+ ----------------------
+ -- NCT_New_Entities --
+ ----------------------
- -- 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).
+ -- The following table maps old entities and Itypes to their corresponding
+ -- new entities and Itypes.
- package NCT_Assoc is new Simple_HTable (
- Header_Num => NCT_Header_Num,
+ -- Aaa -> Xxx
+
+ package NCT_New_Entities is new Simple_HTable (
+ Header_Num => NCT_Table_Index,
Element => Entity_Id,
No_Element => Empty,
Key => Entity_Id,
- Hash => New_Copy_Hash,
- Equal => Types."=");
+ Hash => NCT_Table_Hash,
+ Equal => "=");
- ---------------------
- -- NCT_Itype_Assoc --
- ---------------------
+ ------------------------
+ -- NCT_Pending_Itypes --
+ ------------------------
- -- 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).
+ -- The following table maps old Associated_Node_For_Itype nodes to a set of
+ -- new itypes. Given a set of old Itypes Aaa, Bbb, and Ccc, where all three
+ -- have the same Associated_Node_For_Itype Ppp, and their corresponding new
+ -- Itypes Xxx, Yyy, Zzz, the table contains the following mapping:
- package NCT_Itype_Assoc is new Simple_HTable (
- Header_Num => NCT_Header_Num,
- Element => Node_Or_Entity_Id,
- No_Element => Empty,
- Key => Entity_Id,
- Hash => New_Copy_Hash,
- Equal => Types."=");
+ -- Ppp -> (Xxx, Yyy, Zzz)
+
+ -- The set is expressed as an Elist
+
+ package NCT_Pending_Itypes is new Simple_HTable (
+ Header_Num => NCT_Table_Index,
+ Element => Elist_Id,
+ No_Element => No_Elist,
+ Key => Node_Id,
+ Hash => NCT_Table_Hash,
+ Equal => "=");
+
+ NCT_Tables_In_Use : Boolean := False;
+ -- This flag keeps track of whether the two tables NCT_New_Entities and
+ -- NCT_Pending_Itypes are in use. The flag is part of an optimization
+ -- where certain operations are not performed if the tables are not in
+ -- use. This saves up to 8% of the entire compilation time spent in the
+ -- front end.
-------------------
-- New_Copy_Tree --
New_Sloc : Source_Ptr := No_Location;
New_Scope : Entity_Id := Empty) return Node_Id
is
+ -- This routine performs low-level tree manipulations and needs access
+ -- to the internals of the tree.
+
+ use Atree.Unchecked_Access;
+ use Atree_Private_Part;
+
EWA_Level : Nat := 0;
- -- By default, copying of defining identifiers is prohibited because
- -- this would introduce an entirely new entity into the tree. The
- -- exception to this general rule is declaration of constants and
- -- variables located in Expression_With_Action nodes.
+ -- This counter keeps track of how many N_Expression_With_Actions nodes
+ -- are encountered during a depth-first traversal of the subtree. These
+ -- nodes may define new entities in their Actions lists and thus require
+ -- special processing.
EWA_Inner_Scope_Level : Nat := 0;
- -- Level of internal scope of defined in EWAs. Used to avoid creating
- -- variables for declarations located in blocks or subprograms defined
- -- in Expression_With_Action nodes.
-
- NCT_Hash_Tables_Used : Boolean := False;
- -- Set to True if hash tables are in use. It is intended to speed up the
- -- common case, which is no hash tables in use. This can save up to 8%
- -- of the entire compilation time spent in the front end.
+ -- This counter keeps track of how many scoping constructs appear within
+ -- an N_Expression_With_Actions node.
+
+ procedure Add_New_Entity (Old_Id : Entity_Id; New_Id : Entity_Id);
+ pragma Inline (Add_New_Entity);
+ -- Add an entry in the NCT_New_Entities table which maps key Old_Id to
+ -- value New_Id. Old_Id is an entity which appears within the Actions
+ -- list of an N_Expression_With_Actions node, or within an entity map.
+ -- New_Id is the corresponding new entity generated during Phase 1.
+
+ procedure Add_Pending_Itype (Assoc_Nod : Node_Id; Itype : Entity_Id);
+ pragma Inline (Add_New_Entity);
+ -- Add an entry in the NCT_Pending_Itypes which maps key Assoc_Nod to
+ -- value Itype. Assoc_Nod is the associated node of an itype. Itype is
+ -- an itype.
+
+ procedure Build_NCT_Tables (Entity_Map : Elist_Id);
+ pragma Inline (Build_NCT_Tables);
+ -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with the
+ -- information supplied in entity map Entity_Map. The format of the
+ -- entity map must be as follows:
+ --
+ -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
- function Assoc (N : Node_Or_Entity_Id) return Node_Id;
- -- Called during second phase to map entities into their corresponding
- -- copies using the hash table. If the argument is not an entity, or is
- -- not in the hash table, then it is returned unchanged.
+ function Copy_Any_Node_With_Replacement
+ (N : Node_Or_Entity_Id) return Node_Or_Entity_Id;
+ pragma Inline (Copy_Any_Node_With_Replacement);
+ -- Replicate entity or node N by invoking one of the following routines:
+ --
+ -- Copy_Node_With_Replacement
+ -- Corresponding_Entity
+
+ function Copy_Elist_With_Replacement (List : Elist_Id) return Elist_Id;
+ -- Replicate the elements of entity list List
+
+ function Copy_Field_With_Replacement
+ (Field : Union_Id;
+ Old_Par : Node_Id := Empty;
+ New_Par : Node_Id := Empty;
+ Semantic : Boolean := False) return Union_Id;
+ -- Replicate field Field by invoking one of the following routines:
+ --
+ -- Copy_Elist_With_Replacement
+ -- Copy_List_With_Replacement
+ -- Copy_Node_With_Replacement
+ -- Corresponding_Entity
+ --
+ -- If the field is not an entity list, entity, itype, syntactic list,
+ -- or node, then the field is returned unchanged. The routine always
+ -- replicates entities, itypes, and valid syntactic fields. Old_Par is
+ -- the expected parent of a syntactic field. New_Par is the new parent
+ -- associated with a replicated syntactic field. Flag Semantic should
+ -- be set when the input is a semantic field.
+
+ function Copy_List_With_Replacement (List : List_Id) return List_Id;
+ -- Replicate the elements of syntactic list List
+
+ function Copy_Node_With_Replacement (N : Node_Id) return Node_Id;
+ -- Replicate node N
+
+ function Corresponding_Entity (Id : Entity_Id) return Entity_Id;
+ pragma Inline (Corresponding_Entity);
+ -- Return the corresponding new entity of Id generated during Phase 1.
+ -- If there is no such entity, return Id.
+
+ function In_Entity_Map
+ (Id : Entity_Id;
+ Entity_Map : Elist_Id) return Boolean;
+ pragma Inline (In_Entity_Map);
+ -- Determine whether entity Id is one of the old ids specified in entity
+ -- map Entity_Map. The format of the entity map must be as follows:
+ --
+ -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
+
+ procedure Update_CFS_Sloc (N : Node_Or_Entity_Id);
+ pragma Inline (Update_CFS_Sloc);
+ -- Update the Comes_From_Source and Sloc attributes of node or entity N
+
+ procedure Update_First_Real_Statement
+ (Old_HSS : Node_Id;
+ New_HSS : Node_Id);
+ pragma Inline (Update_First_Real_Statement);
+ -- Update semantic attribute First_Real_Statement of handled sequence of
+ -- statements New_HSS based on handled sequence of statements Old_HSS.
+
+ procedure Update_Named_Associations
+ (Old_Call : Node_Id;
+ New_Call : Node_Id);
+ pragma Inline (Update_Named_Associations);
+ -- Update semantic chain First/Next_Named_Association of call New_call
+ -- based on call Old_Call.
+
+ procedure Update_New_Entities (Entity_Map : Elist_Id);
+ pragma Inline (Update_New_Entities);
+ -- Update the semantic attributes of all new entities generated during
+ -- Phase 1 that do not appear in entity map Entity_Map. The format of
+ -- the entity map must be as follows:
+ --
+ -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
+
+ procedure Update_Pending_Itypes
+ (Old_Assoc : Node_Id;
+ New_Assoc : Node_Id);
+ pragma Inline (Update_Pending_Itypes);
+ -- Update semantic attribute Associated_Node_For_Itype to refer to node
+ -- New_Assoc for all itypes whose associated node is Old_Assoc.
+
+ procedure Update_Semantic_Fields (Id : Entity_Id);
+ pragma Inline (Update_Semantic_Fields);
+ -- Subsidiary to Update_New_Entities. Update semantic fields of entity
+ -- or itype Id.
+
+ procedure Visit_Any_Node (N : Node_Or_Entity_Id);
+ pragma Inline (Visit_Any_Node);
+ -- Visit entity of node N by invoking one of the following routines:
+ --
+ -- Visit_Entity
+ -- Visit_Itype
+ -- Visit_Node
+
+ procedure Visit_Elist (List : Elist_Id);
+ -- Visit the elements of entity list List
+
+ procedure Visit_Entity (Id : Entity_Id);
+ -- Visit entity Id. This action may create a new entity of Id and save
+ -- it in table NCT_New_Entities.
+
+ procedure Visit_Field
+ (Field : Union_Id;
+ Par_Nod : Node_Id := Empty;
+ Semantic : Boolean := False);
+ -- Visit field Field by invoking one of the following routines:
+ --
+ -- Visit_Elist
+ -- Visit_Entity
+ -- Visit_Itype
+ -- Visit_List
+ -- Visit_Node
+ --
+ -- If the field is not an entity list, entity, itype, syntactic list,
+ -- or node, then the field is not visited. The routine always visits
+ -- valid syntactic fields. Par_Nod is the expected parent of the
+ -- syntactic field. Flag Semantic should be set when the input is a
+ -- semantic field.
- procedure Build_NCT_Hash_Tables;
- -- Builds hash tables
+ procedure Visit_Itype (Itype : Entity_Id);
+ -- Visit itype Itype. This action may create a new entity for Itype and
+ -- save it in table NCT_New_Entities. In addition, the routine may map
+ -- the associated node of Itype to the new itype in NCT_Pending_Itypes.
- function Copy_Elist_With_Replacement
- (Old_Elist : Elist_Id) return Elist_Id;
- -- Called during second phase to copy element list doing replacements
+ procedure Visit_List (List : List_Id);
+ -- Visit the elements of syntactic list List
- procedure Copy_Entity_With_Replacement (New_Entity : Entity_Id);
- -- Called during the second phase to process a copied Entity. 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 descendants of
- -- the copied Entity and copy them where necessary.
+ procedure Visit_Node (N : Node_Id);
+ -- Visit node N
- function Copy_List_With_Replacement (Old_List : List_Id) return List_Id;
- -- Called during second phase to copy list doing replacements
+ procedure Visit_Semantic_Fields (Id : Entity_Id);
+ pragma Inline (Visit_Semantic_Fields);
+ -- Subsidiary to Visit_Entity and Visit_Itype. Visit common semantic
+ -- fields of entity or itype Id.
- function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id;
- -- Called during second phase to copy node doing replacements
+ --------------------
+ -- Add_New_Entity --
+ --------------------
- function In_Map (E : Entity_Id) return Boolean;
- -- Return True if E is one of the old entities specified in the set of
- -- mappings to be applied to entities in the tree (i.e. Map).
+ procedure Add_New_Entity (Old_Id : Entity_Id; New_Id : Entity_Id) is
+ begin
+ pragma Assert (Present (Old_Id));
+ pragma Assert (Present (New_Id));
+ pragma Assert (Nkind (Old_Id) in N_Entity);
+ pragma Assert (Nkind (New_Id) in N_Entity);
- procedure Visit_Elist (E : Elist_Id);
- -- Called during first phase to visit all elements of an Elist
+ NCT_Tables_In_Use := True;
- procedure Visit_Entity (Old_Entity : Entity_Id);
- -- Called during first phase to visit subsidiary fields of a defining
- -- entity which is not an itype, and also create a copy and make an
- -- entry in the replacement map for the new copy.
+ -- Sanity check the NCT_New_Entities table. No previous mapping with
+ -- key Old_Id should exist.
- 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 descendant of the current node (i.e. its
- -- parent is Node N).
+ pragma Assert (No (NCT_New_Entities.Get (Old_Id)));
- 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.
+ -- Establish the mapping
- procedure Visit_List (L : List_Id);
- -- Called during first phase to visit all elements of a List
+ -- Old_Id -> New_Id
- procedure Visit_Node (N : Node_Or_Entity_Id);
- -- Called during first phase to visit a node and all its subtrees
+ NCT_New_Entities.Set (Old_Id, New_Id);
+ end Add_New_Entity;
- -----------
- -- Assoc --
- -----------
+ -----------------------
+ -- Add_Pending_Itype --
+ -----------------------
- function Assoc (N : Node_Or_Entity_Id) return Node_Id is
- Ent : Entity_Id;
+ procedure Add_Pending_Itype (Assoc_Nod : Node_Id; Itype : Entity_Id) is
+ Itypes : Elist_Id;
begin
- if Nkind (N) not in N_Entity or else not NCT_Hash_Tables_Used then
- return N;
+ pragma Assert (Present (Assoc_Nod));
+ pragma Assert (Present (Itype));
+ pragma Assert (Nkind (Itype) in N_Entity);
+ pragma Assert (Is_Itype (Itype));
- else
- Ent := NCT_Assoc.Get (Entity_Id (N));
+ NCT_Tables_In_Use := True;
- if Present (Ent) then
- return Ent;
- end if;
+ -- It is not possible to sanity check the NCT_Pendint_Itypes table
+ -- directly because a single node may act as the associated node for
+ -- multiple itypes.
+
+ Itypes := NCT_Pending_Itypes.Get (Assoc_Nod);
+
+ if No (Itypes) then
+ Itypes := New_Elmt_List;
+ NCT_Pending_Itypes.Set (Assoc_Nod, Itypes);
end if;
- return N;
- end Assoc;
+ -- Establish the mapping
- ---------------------------
- -- Build_NCT_Hash_Tables --
- ---------------------------
+ -- Assoc_Nod -> (Itype, ...)
+
+ -- Avoid inserting the same itype multiple times. This involves a
+ -- linear search, however the set of itypes with the same associated
+ -- node is very small.
+
+ Append_Unique_Elmt (Itype, Itypes);
+ end Add_Pending_Itype;
+
+ ----------------------
+ -- Build_NCT_Tables --
+ ----------------------
- procedure Build_NCT_Hash_Tables is
- Assoc : Entity_Id;
- Elmt : Elmt_Id;
- Key : Entity_Id;
- Value : Entity_Id;
+ procedure Build_NCT_Tables (Entity_Map : Elist_Id) is
+ Elmt : Elmt_Id;
+ Old_Id : Entity_Id;
+ New_Id : Entity_Id;
begin
- if No (Map) then
+ -- Nothing to do when there is no entity map
+
+ if No (Entity_Map) then
return;
end if;
- -- Clear both hash tables associated with entry replication since
- -- multiple calls to New_Copy_Tree could cause multiple collisions
- -- and produce long linked lists in individual buckets.
-
- NCT_Assoc.Reset;
- NCT_Itype_Assoc.Reset;
-
- Elmt := First_Elmt (Map);
+ Elmt := First_Elmt (Entity_Map);
while Present (Elmt) loop
- -- Extract a (key, value) pair from the map
+ -- Extract the (Old_Id, New_Id) pair from the entity map
- Key := Node (Elmt);
+ Old_Id := Node (Elmt);
Next_Elmt (Elmt);
- Value := Node (Elmt);
- -- Add the pair in the association hash table
+ New_Id := Node (Elmt);
+ Next_Elmt (Elmt);
- NCT_Assoc.Set (Key, Value);
+ -- Establish the following mapping within table NCT_New_Entities
- -- Add a link between the associated node of the old Itype and the
- -- new Itype, for updating later when node is copied.
+ -- Old_Id -> New_Id
- if Is_Type (Key) then
- Assoc := Associated_Node_For_Itype (Key);
+ Add_New_Entity (Old_Id, New_Id);
- if Present (Assoc) then
- NCT_Itype_Assoc.Set (Assoc, Value);
- end if;
- end if;
+ -- Establish the following mapping within table NCT_Pending_Itypes
+ -- when the new entity is an itype.
- Next_Elmt (Elmt);
+ -- Assoc_Nod -> (New_Id, ...)
+
+ -- IMPORTANT: the associated node is that of the old itype because
+ -- the node will be replicated in Phase 2.
+
+ if Is_Itype (Old_Id) then
+ Add_Pending_Itype
+ (Assoc_Nod => Associated_Node_For_Itype (Old_Id),
+ Itype => New_Id);
+ end if;
end loop;
+ end Build_NCT_Tables;
- NCT_Hash_Tables_Used := True;
- end Build_NCT_Hash_Tables;
+ ------------------------------------
+ -- Copy_Any_Node_With_Replacement --
+ ------------------------------------
+
+ function Copy_Any_Node_With_Replacement
+ (N : Node_Or_Entity_Id) return Node_Or_Entity_Id
+ is
+ begin
+ if Nkind (N) in N_Entity then
+ return Corresponding_Entity (N);
+ else
+ return Copy_Node_With_Replacement (N);
+ end if;
+ end Copy_Any_Node_With_Replacement;
---------------------------------
-- Copy_Elist_With_Replacement --
---------------------------------
- function Copy_Elist_With_Replacement
- (Old_Elist : Elist_Id) return Elist_Id
- is
- M : Elmt_Id;
- New_Elist : Elist_Id;
+ function Copy_Elist_With_Replacement (List : Elist_Id) return Elist_Id is
+ Elmt : Elmt_Id;
+ Result : Elist_Id;
begin
- if No (Old_Elist) then
- return No_Elist;
+ -- Copy the contents of the old list. Note that the list itself may
+ -- be empty, in which case the routine returns a new empty list. This
+ -- avoids sharing lists between subtrees. The element of an entity
+ -- list could be an entity or a node, hence the invocation of routine
+ -- Copy_Any_Node_With_Replacement.
- else
- New_Elist := New_Elmt_List;
+ if Present (List) then
+ Result := 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);
+ Elmt := First_Elmt (List);
+ while Present (Elmt) loop
+ Append_Elmt
+ (Copy_Any_Node_With_Replacement (Node (Elmt)), Result);
+
+ Next_Elmt (Elmt);
end loop;
+
+ -- Otherwise the list does not exist
+
+ else
+ Result := No_Elist;
end if;
- return New_Elist;
+ return Result;
end Copy_Elist_With_Replacement;
- ----------------------------------
- -- Copy_Entity_With_Replacement --
- ----------------------------------
-
- -- This routine exactly parallels its phase one analog Visit_Itype
+ ---------------------------------
+ -- Copy_Field_With_Replacement --
+ ---------------------------------
- procedure Copy_Entity_With_Replacement (New_Entity : Entity_Id) is
+ function Copy_Field_With_Replacement
+ (Field : Union_Id;
+ Old_Par : Node_Id := Empty;
+ New_Par : Node_Id := Empty;
+ Semantic : Boolean := False) return Union_Id
+ is
begin
- -- Translate Next_Entity, Scope, and Etype fields, in case they
- -- reference entities that have been mapped into copies.
+ -- The field is empty
- Set_Next_Entity (New_Entity, Assoc (Next_Entity (New_Entity)));
- Set_Etype (New_Entity, Assoc (Etype (New_Entity)));
+ if Field = Union_Id (Empty) then
+ return Field;
- if Present (New_Scope) then
- Set_Scope (New_Entity, New_Scope);
- else
- Set_Scope (New_Entity, Assoc (Scope (New_Entity)));
- end if;
+ -- The field is an entity/itype/node
- -- Copy referenced fields
+ elsif Field in Node_Range then
+ declare
+ Old_N : constant Node_Id := Node_Id (Field);
+ Syntactic : constant Boolean := Parent (Old_N) = Old_Par;
- if Is_Discrete_Type (New_Entity) then
- Set_Scalar_Range (New_Entity,
- Copy_Node_With_Replacement (Scalar_Range (New_Entity)));
+ New_N : Node_Id;
- elsif Has_Discriminants (Base_Type (New_Entity)) then
- Set_Discriminant_Constraint (New_Entity,
- Copy_Elist_With_Replacement
- (Discriminant_Constraint (New_Entity)));
+ begin
+ -- The field is an entity/itype
- elsif Is_Array_Type (New_Entity) then
- if Present (First_Index (New_Entity)) then
- Set_First_Index (New_Entity,
- First (Copy_List_With_Replacement
- (List_Containing (First_Index (New_Entity)))));
- end if;
+ if Nkind (Old_N) in N_Entity then
- if Is_Packed (New_Entity) then
- Set_Packed_Array_Impl_Type (New_Entity,
- Copy_Node_With_Replacement
- (Packed_Array_Impl_Type (New_Entity)));
- end if;
+ -- An entity/itype is always replicated
+
+ New_N := Corresponding_Entity (Old_N);
+
+ -- Update the parent pointer when the entity is a syntactic
+ -- field. Note that itypes do not have parent pointers.
+
+ if Syntactic and then New_N /= Old_N then
+ Set_Parent (New_N, New_Par);
+ end if;
+
+ -- The field is a node
+
+ else
+ -- A node is replicated when it is either a syntactic field
+ -- or when the caller treats it as a semantic attribute.
+
+ if Syntactic or else Semantic then
+ New_N := Copy_Node_With_Replacement (Old_N);
+
+ -- Update the parent pointer when the node is a syntactic
+ -- field.
+
+ if Syntactic and then New_N /= Old_N then
+ Set_Parent (New_N, New_Par);
+ end if;
+
+ -- Otherwise the node is returned unchanged
+
+ else
+ New_N := Old_N;
+ end if;
+ end if;
+
+ return Union_Id (New_N);
+ end;
+
+ -- The field is an entity list
+
+ elsif Field in Elist_Range then
+ return Union_Id (Copy_Elist_With_Replacement (Elist_Id (Field)));
+
+ -- The field is a syntactic list
+
+ elsif Field in List_Range then
+ declare
+ Old_List : constant List_Id := List_Id (Field);
+ Syntactic : constant Boolean := Parent (Old_List) = Old_Par;
+
+ New_List : List_Id;
+
+ begin
+ -- A list is replicated when it is either a syntactic field or
+ -- when the caller treats it as a semantic attribute.
+
+ if Syntactic or else Semantic then
+ New_List := Copy_List_With_Replacement (Old_List);
+
+ -- Update the parent pointer when the list is a syntactic
+ -- field.
+
+ if Syntactic and then New_List /= Old_List then
+ Set_Parent (New_List, New_Par);
+ end if;
+
+ -- Otherwise the list is returned unchanged
+
+ else
+ New_List := Old_List;
+ end if;
+
+ return Union_Id (New_List);
+ end;
+
+ -- Otherwise the field denotes an attribute that does not need to be
+ -- replicated (Chars, literals, etc).
+
+ else
+ return Field;
end if;
- end Copy_Entity_With_Replacement;
+ end Copy_Field_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;
+ function Copy_List_With_Replacement (List : List_Id) return List_Id is
+ Elmt : Node_Id;
+ Result : List_Id;
begin
- if Old_List = No_List then
- return No_List;
+ -- Copy the contents of the old list. Note that the list itself may
+ -- be empty, in which case the routine returns a new empty list. This
+ -- avoids sharing lists between subtrees. The element of a syntactic
+ -- list is always a node, never an entity or itype, hence the call to
+ -- routine Copy_Node_With_Replacement.
- else
- New_List := Empty_List;
+ if Present (List) then
+ Result := New_List;
+
+ Elmt := First (List);
+ while Present (Elmt) loop
+ Append (Copy_Node_With_Replacement (Elmt), Result);
- E := First (Old_List);
- while Present (E) loop
- Append (Copy_Node_With_Replacement (E), New_List);
- Next (E);
+ Next (Elmt);
end loop;
- return New_List;
+ -- Otherwise the list does not exist
+
+ else
+ Result := No_List;
end if;
+
+ return Result;
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;
+ function Copy_Node_With_Replacement (N : Node_Id) return Node_Id is
+ Result : Node_Id;
- Old_Next : Node_Id;
- New_Next : Node_Id;
+ begin
+ -- Assume that the node must be returned unchanged
+
+ Result := N;
+
+ if N > Empty_Or_Error then
+ pragma Assert (Nkind (N) not in N_Entity);
+
+ Result := New_Copy (N);
+
+ Set_Field1 (Result,
+ Copy_Field_With_Replacement
+ (Field => Field1 (Result),
+ Old_Par => N,
+ New_Par => Result));
+
+ Set_Field2 (Result,
+ Copy_Field_With_Replacement
+ (Field => Field2 (Result),
+ Old_Par => N,
+ New_Par => Result));
+
+ Set_Field3 (Result,
+ Copy_Field_With_Replacement
+ (Field => Field3 (Result),
+ Old_Par => N,
+ New_Par => Result));
+
+ Set_Field4 (Result,
+ Copy_Field_With_Replacement
+ (Field => Field4 (Result),
+ Old_Par => N,
+ New_Par => Result));
+
+ Set_Field5 (Result,
+ Copy_Field_With_Replacement
+ (Field => Field5 (Result),
+ Old_Par => N,
+ New_Par => Result));
+
+ -- Update the Comes_From_Source and Sloc attributes of the node
+ -- in case the caller has supplied new values.
+
+ Update_CFS_Sloc (Result);
+
+ -- Update the Associated_Node_For_Itype attribute of all itypes
+ -- created during Phase 1 whose associated node is N. As a result
+ -- the Associated_Node_For_Itype refers to the replicated node.
+ -- No action needs to be taken when the Associated_Node_For_Itype
+ -- refers to an entity because this was already handled during
+ -- Phase 1, in Visit_Itype.
+
+ Update_Pending_Itypes
+ (Old_Assoc => N,
+ New_Assoc => Result);
+
+ -- Update the First/Next_Named_Association chain for a replicated
+ -- call.
+
+ if Nkind_In (N, N_Entry_Call_Statement,
+ N_Function_Call,
+ N_Procedure_Call_Statement)
+ then
+ Update_Named_Associations
+ (Old_Call => N,
+ New_Call => Result);
- 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;
+ -- Update the Renamed_Object attribute of a replicated object
+ -- declaration.
- -- 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;
+ elsif Nkind (N) = N_Object_Renaming_Declaration then
+ Set_Renamed_Object (Defining_Entity (Result), Name (Result));
- Set_Next_Named_Actual
- (New_E, Explicit_Actual_Parameter (New_Next));
- end if;
+ -- Update the First_Real_Statement attribute of a replicated
+ -- handled sequence of statements.
- Next (Old_E);
- Next (New_E);
- end loop;
- end Adjust_Named_Associations;
+ elsif Nkind (N) = N_Handled_Sequence_Of_Statements then
+ Update_First_Real_Statement
+ (Old_HSS => N,
+ New_HSS => Result);
+ end if;
+ end if;
- ---------------------------------
- -- Copy_Field_With_Replacement --
- ---------------------------------
+ return Result;
+ end Copy_Node_With_Replacement;
- function Copy_Field_With_Replacement
- (Field : Union_Id) return Union_Id
- is
- begin
- if Field = Union_Id (Empty) then
- return Field;
+ --------------------------
+ -- Corresponding_Entity --
+ --------------------------
- elsif Field in Node_Range then
- declare
- Old_N : constant Node_Id := Node_Id (Field);
- New_N : Node_Id;
+ function Corresponding_Entity (Id : Entity_Id) return Entity_Id is
+ New_Id : Entity_Id;
+ Result : Entity_Id;
- begin
- -- If syntactic field, as indicated by the parent pointer
- -- being set, then copy the referenced node recursively.
+ begin
+ -- Assume that the entity must be returned unchanged
- if Parent (Old_N) = Old_Node then
- New_N := Copy_Node_With_Replacement (Old_N);
+ Result := Id;
- if New_N /= Old_N then
- Set_Parent (New_N, New_Node);
- end if;
+ if Id > Empty_Or_Error then
+ pragma Assert (Nkind (Id) in N_Entity);
- -- For semantic fields, update possible entity reference
- -- from the replacement map.
+ -- Determine whether the entity has a corresponding new entity
+ -- generated during Phase 1 and if it does, use it.
- else
- New_N := Assoc (Old_N);
- end if;
+ if NCT_Tables_In_Use then
+ New_Id := NCT_New_Entities.Get (Id);
- return Union_Id (New_N);
- end;
+ if Present (New_Id) then
+ Result := New_Id;
+ end if;
+ end if;
+ end if;
- elsif Field in List_Range then
- declare
- Old_L : constant List_Id := List_Id (Field);
- New_L : List_Id;
+ return Result;
+ end Corresponding_Entity;
- begin
- -- If syntactic field, as indicated by the parent pointer,
- -- then recursively copy the entire referenced list.
+ -------------------
+ -- In_Entity_Map --
+ -------------------
- if Parent (Old_L) = Old_Node then
- New_L := Copy_List_With_Replacement (Old_L);
- Set_Parent (New_L, New_Node);
+ function In_Entity_Map
+ (Id : Entity_Id;
+ Entity_Map : Elist_Id) return Boolean
+ is
+ Elmt : Elmt_Id;
+ Old_Id : Entity_Id;
- -- For semantic list, just returned unchanged
+ begin
+ -- The entity map contains pairs (Old_Id, New_Id). The advancement
+ -- step always skips the New_Id portion of the pair.
- else
- New_L := Old_L;
- end if;
+ if Present (Entity_Map) then
+ Elmt := First_Elmt (Entity_Map);
+ while Present (Elmt) loop
+ Old_Id := Node (Elmt);
- return Union_Id (New_L);
- end;
+ if Old_Id = Id then
+ return True;
+ end if;
- -- Anything other than a list or a node is returned unchanged
+ Next_Elmt (Elmt);
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
- else
- return Field;
- end if;
- end Copy_Field_With_Replacement;
+ return False;
+ end In_Entity_Map;
- -- Start of processing for Copy_Node_With_Replacement
+ ---------------------
+ -- Update_CFS_Sloc --
+ ---------------------
+ procedure Update_CFS_Sloc (N : Node_Or_Entity_Id) is
begin
- if Old_Node <= Empty_Or_Error then
- return Old_Node;
+ -- A new source location defaults the Comes_From_Source attribute
- elsif Nkind (Old_Node) in N_Entity then
- return Assoc (Old_Node);
+ if New_Sloc /= No_Location then
+ Set_Comes_From_Source (N, Default_Node.Comes_From_Source);
+ Set_Sloc (N, New_Sloc);
+ end if;
+ end Update_CFS_Sloc;
- else
- New_Node := New_Copy (Old_Node);
+ ---------------------------------
+ -- Update_First_Real_Statement --
+ ---------------------------------
- -- 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.
+ procedure Update_First_Real_Statement
+ (Old_HSS : Node_Id;
+ New_HSS : Node_Id)
+ is
+ Old_First_Stmt : constant Node_Id := First_Real_Statement (Old_HSS);
- declare
- Ent : constant Entity_Id := NCT_Itype_Assoc.Get (Old_Node);
+ New_Stmt : Node_Id;
+ Old_Stmt : Node_Id;
- begin
- if Present (Ent) then
- Set_Associated_Node_For_Itype (Ent, New_Node);
- end if;
- end;
+ begin
+ -- Recreate the First_Real_Statement attribute of a handled sequence
+ -- of statements by traversing the statement lists of both sequences
+ -- in parallel.
+
+ if Present (Old_First_Stmt) then
+ New_Stmt := First (Statements (New_HSS));
+ Old_Stmt := First (Statements (Old_HSS));
+ while Present (Old_Stmt) and then Old_Stmt /= Old_First_Stmt loop
+ Next (New_Stmt);
+ Next (Old_Stmt);
+ end loop;
- -- Recursively copy descendants
+ pragma Assert (Present (New_Stmt));
+ pragma Assert (Present (Old_Stmt));
- 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)));
+ Set_First_Real_Statement (New_HSS, New_Stmt);
+ end if;
+ end Update_First_Real_Statement;
- -- Adjust Sloc of new node if necessary
+ -------------------------------
+ -- Update_Named_Associations --
+ -------------------------------
- if New_Sloc /= No_Location then
- Set_Sloc (New_Node, New_Sloc);
+ procedure Update_Named_Associations
+ (Old_Call : Node_Id;
+ New_Call : Node_Id)
+ is
+ New_Act : Node_Id;
+ New_Next : Node_Id;
+ Old_Act : Node_Id;
+ Old_Next : Node_Id;
- -- 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.
+ begin
+ -- Recreate the First/Next_Named_Actual chain of a call by traversing
+ -- the chains of both the old and new calls in parallel.
+
+ New_Act := First (Parameter_Associations (New_Call));
+ Old_Act := First (Parameter_Associations (Old_Call));
+ while Present (Old_Act) loop
+ if Nkind (Old_Act) = N_Parameter_Association
+ and then Present (Next_Named_Actual (Old_Act))
+ then
+ if First_Named_Actual (Old_Call) =
+ Explicit_Actual_Parameter (Old_Act)
+ then
+ Set_First_Named_Actual (New_Call,
+ Explicit_Actual_Parameter (New_Act));
+ end if;
+
+ -- Scan the actual parameter list to find the next suitable
+ -- named actual. Note that the list may be out of order.
- Set_Comes_From_Source
- (New_Node, Default_Node.Comes_From_Source);
+ New_Next := First (Parameter_Associations (New_Call));
+ Old_Next := First (Parameter_Associations (Old_Call));
+ while Nkind (Old_Next) /= N_Parameter_Association
+ or else Explicit_Actual_Parameter (Old_Next) /=
+ Next_Named_Actual (Old_Act)
+ loop
+ Next (New_Next);
+ Next (Old_Next);
+ end loop;
+
+ Set_Next_Named_Actual (New_Act,
+ Explicit_Actual_Parameter (New_Next));
end if;
- -- Update the named association links for calls to mention the
- -- copied actual parameters.
+ Next (New_Act);
+ Next (Old_Act);
+ end loop;
+ end Update_Named_Associations;
- if Nkind_In (Old_Node, N_Entry_Call_Statement,
- N_Function_Call,
- N_Procedure_Call_Statement)
- and then Present (First_Named_Actual (Old_Node))
- then
- Adjust_Named_Associations (Old_Node, New_Node);
+ -------------------------
+ -- Update_New_Entities --
+ -------------------------
+
+ procedure Update_New_Entities (Entity_Map : Elist_Id) is
+ New_Id : Entity_Id := Empty;
+ Old_Id : Entity_Id := Empty;
+
+ begin
+ if NCT_Tables_In_Use then
+ NCT_New_Entities.Get_First (Old_Id, New_Id);
+
+ -- Update the semantic fields of all new entities created during
+ -- Phase 1 which were not supplied via an entity map.
+ -- ??? Is there a better way of distinguishing those?
+
+ while Present (Old_Id) and then Present (New_Id) loop
+ if not (Present (Entity_Map)
+ and then In_Entity_Map (Old_Id, Entity_Map))
+ then
+ Update_Semantic_Fields (New_Id);
+ end if;
- -- Update the Renamed_Object attribute of an object renaming
- -- declaration to mention the replicated name.
+ NCT_New_Entities.Get_Next (Old_Id, New_Id);
+ end loop;
+ end if;
+ end Update_New_Entities;
+
+ ---------------------------
+ -- Update_Pending_Itypes --
+ ---------------------------
+
+ procedure Update_Pending_Itypes
+ (Old_Assoc : Node_Id;
+ New_Assoc : Node_Id)
+ is
+ Item : Elmt_Id;
+ Itypes : Elist_Id;
- elsif Nkind (Old_Node) = N_Object_Renaming_Declaration then
- Set_Renamed_Object
- (Defining_Entity (New_Node), Name (New_Node));
+ begin
+ if NCT_Tables_In_Use then
+ Itypes := NCT_Pending_Itypes.Get (Old_Assoc);
+
+ -- Update the Associated_Node_For_Itype attribute for all itypes
+ -- which originally refer to Old_Assoc to designate New_Assoc.
+
+ if Present (Itypes) then
+ Item := First_Elmt (Itypes);
+ while Present (Item) loop
+ Set_Associated_Node_For_Itype (Node (Item), New_Assoc);
+
+ Next_Elmt (Item);
+ end loop;
end if;
+ end if;
+ end Update_Pending_Itypes;
- -- 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.
+ ----------------------------
+ -- Update_Semantic_Fields --
+ ----------------------------
- 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 : Node_Id;
- N2 : Node_Id;
+ procedure Update_Semantic_Fields (Id : Entity_Id) is
+ begin
+ -- Discriminant_Constraint
- begin
- N1 := First (Statements (Old_Node));
- N2 := First (Statements (New_Node));
+ if Has_Discriminants (Base_Type (Id)) then
+ Set_Discriminant_Constraint (Id, Elist_Id (
+ Copy_Field_With_Replacement
+ (Field => Union_Id (Discriminant_Constraint (Id)),
+ Semantic => True)));
+ end if;
- while N1 /= Old_F loop
- Next (N1);
- Next (N2);
- end loop;
+ -- Etype
- Set_First_Real_Statement (New_Node, N2);
- end;
+ Set_Etype (Id, Node_Id (
+ Copy_Field_With_Replacement
+ (Field => Union_Id (Etype (Id)),
+ Semantic => True)));
+
+ -- First_Index
+ -- Packed_Array_Impl_Type
+
+ if Is_Array_Type (Id) then
+ if Present (First_Index (Id)) then
+ Set_First_Index (Id, First (List_Id (
+ Copy_Field_With_Replacement
+ (Field => Union_Id (List_Containing (First_Index (Id))),
+ Semantic => True))));
+ end if;
+
+ if Is_Packed (Id) then
+ Set_Packed_Array_Impl_Type (Id, Node_Id (
+ Copy_Field_With_Replacement
+ (Field => Union_Id (Packed_Array_Impl_Type (Id)),
+ Semantic => True)));
end if;
end if;
- -- All done, return copied node
+ -- Next_Entity
- return New_Node;
- end Copy_Node_With_Replacement;
+ Set_Next_Entity (Id, Node_Id (
+ Copy_Field_With_Replacement
+ (Field => Union_Id (Next_Entity (Id)),
+ Semantic => True)));
- ------------
- -- In_Map --
- ------------
+ -- Scalar_Range
- function In_Map (E : Entity_Id) return Boolean is
- Elmt : Elmt_Id;
- Ent : Entity_Id;
+ if Is_Discrete_Type (Id) then
+ Set_Scalar_Range (Id, Node_Id (
+ Copy_Field_With_Replacement
+ (Field => Union_Id (Scalar_Range (Id)),
+ Semantic => True)));
+ end if;
- begin
- if Present (Map) then
- Elmt := First_Elmt (Map);
- while Present (Elmt) loop
- Ent := Node (Elmt);
+ -- Scope
- if Ent = E then
- return True;
- end if;
+ -- Update the scope when the caller specified an explicit one
- Next_Elmt (Elmt);
- Next_Elmt (Elmt);
- end loop;
+ if Present (New_Scope) then
+ Set_Scope (Id, New_Scope);
+ else
+ Set_Scope (Id, Node_Id (
+ Copy_Field_With_Replacement
+ (Field => Union_Id (Scope (Id)),
+ Semantic => True)));
end if;
+ end Update_Semantic_Fields;
- return False;
- end In_Map;
+ --------------------
+ -- Visit_Any_Node --
+ --------------------
+
+ procedure Visit_Any_Node (N : Node_Or_Entity_Id) is
+ begin
+ if Nkind (N) in N_Entity then
+ if Is_Itype (N) then
+ Visit_Itype (N);
+ else
+ Visit_Entity (N);
+ end if;
+ else
+ Visit_Node (N);
+ end if;
+ end Visit_Any_Node;
-----------------
-- Visit_Elist --
-----------------
- procedure Visit_Elist (E : Elist_Id) is
+ procedure Visit_Elist (List : Elist_Id) is
Elmt : Elmt_Id;
+
begin
- if Present (E) then
- Elmt := First_Elmt (E);
+ -- The element of an entity list could be an entity, itype, or a
+ -- node, hence the call to Visit_Any_Node.
+
+ if Present (List) then
+ Elmt := First_Elmt (List);
+ while Present (Elmt) loop
+ Visit_Any_Node (Node (Elmt));
- while Elmt /= No_Elmt loop
- Visit_Node (Node (Elmt));
Next_Elmt (Elmt);
end loop;
end if;
-- Visit_Entity --
------------------
- procedure Visit_Entity (Old_Entity : Entity_Id) is
- New_E : Entity_Id;
+ procedure Visit_Entity (Id : Entity_Id) is
+ New_Id : Entity_Id;
begin
- pragma Assert (not Is_Itype (Old_Entity));
- pragma Assert (Nkind (Old_Entity) in N_Entity);
+ pragma Assert (Nkind (Id) in N_Entity);
+ pragma Assert (not Is_Itype (Id));
- -- Do not duplicate an entity when it is declared within an inner
- -- scope enclosed by an expression with actions.
+ -- Nothing to do if the entity is not defined in the Actions list of
+ -- an N_Expression_With_Actions node.
- if EWA_Inner_Scope_Level > 0 then
+ if EWA_Level = 0 then
return;
- -- Entity duplication is currently performed only for objects and
- -- types. Relaxing this restriction leads to a performance penalty.
+ -- Nothing to do if the entity is defined within a scoping construct
+ -- of an N_Expression_With_Actions node.
- elsif Ekind_In (Old_Entity, E_Constant, E_Variable) then
- null;
+ elsif EWA_Inner_Scope_Level > 0 then
+ return;
- elsif Is_Type (Old_Entity) then
- null;
+ -- Nothing to do if the entity is not an object or a type. Relaxing
+ -- this restriction leads to a performance penalty.
- else
+ elsif not Ekind_In (Id, E_Constant, E_Variable)
+ and then not Is_Type (Id)
+ then
+ return;
+
+ -- Nothing to do if the entity was already visited
+
+ elsif NCT_Tables_In_Use
+ and then Present (NCT_New_Entities.Get (Id))
+ then
+ return;
+
+ -- Nothing to do if the declaration node of the entity is not within
+ -- the subtree being replicated.
+
+ elsif not In_Subtree
+ (N => Declaration_Node (Id),
+ Root => Source)
+ then
return;
end if;
- New_E := New_Copy (Old_Entity);
+ -- Create a new entity by directly copying the old entity. This
+ -- action causes all attributes of the old entity to be inherited.
- -- The new entity has all the attributes of the old one, however it
- -- requires a new name for debugging purposes.
+ New_Id := New_Copy (Id);
- Set_Chars (New_E, New_Internal_Name ('T'));
+ -- Create a new name for the new entity because the back end needs
+ -- distinct names for debugging purposes.
- -- Add new association to map
+ Set_Chars (New_Id, New_Internal_Name ('T'));
- NCT_Assoc.Set (Old_Entity, New_E);
- NCT_Hash_Tables_Used := True;
+ -- Update the Comes_From_Source and Sloc attributes of the entity in
+ -- case the caller has supplied new values.
- -- Visit descendants that eventually get copied
+ Update_CFS_Sloc (New_Id);
- Visit_Field (Union_Id (Etype (Old_Entity)), Old_Entity);
+ -- Establish the following mapping within table NCT_New_Entities:
+
+ -- Id -> New_Id
+
+ Add_New_Entity (Id, New_Id);
+
+ -- Deal with the semantic fields of entities. The fields are visited
+ -- because they may mention entities which reside within the subtree
+ -- being copied.
+
+ Visit_Semantic_Fields (Id);
end Visit_Entity;
-----------------
-- Visit_Field --
-----------------
- procedure Visit_Field (F : Union_Id; N : Node_Id) is
+ procedure Visit_Field
+ (Field : Union_Id;
+ Par_Nod : Node_Id := Empty;
+ Semantic : Boolean := False)
+ is
begin
- if F = Union_Id (Empty) then
+ -- The field is empty
+
+ if Field = Union_Id (Empty) then
return;
- elsif F in Node_Range then
+ -- The field is an entity/itype/node
- -- 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.)
+ elsif Field in Node_Range then
+ declare
+ N : constant Node_Id := Node_Id (Field);
- if Parent (Node_Id (F)) = N then
- Visit_Node (Node_Id (F));
- return;
+ begin
+ -- The field is an entity/itype
- -- 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.
+ if Nkind (N) in N_Entity then
- -- 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).
+ -- Itypes are always visited
- elsif Nkind (Node_Id (F)) in N_Entity
- and then Is_Itype (Entity_Id (F))
- and then Node_Id (F) /= N
- then
- declare
- P : Node_Id;
+ if Is_Itype (N) then
+ Visit_Itype (N);
+
+ -- An entity is visited when it is either a syntactic field
+ -- or when the caller treats it as a semantic attribute.
+
+ elsif Parent (N) = Par_Nod or else Semantic then
+ Visit_Entity (N);
+ end if;
+
+ -- The field is a node
+
+ else
+ -- A node is visited when it is either a syntactic field or
+ -- when the caller treats it as a semantic attribute.
+
+ if Parent (N) = Par_Nod or else Semantic then
+ Visit_Node (N);
+ end if;
+ end if;
+ end;
+
+ -- The field is an entity list
+
+ elsif Field in Elist_Range then
+ Visit_Elist (Elist_Id (Field));
+
+ -- The field is a syntax list
+
+ elsif Field in List_Range then
+ declare
+ List : constant List_Id := List_Id (Field);
- 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;
+ begin
+ -- A syntax list is visited when it is either a syntactic field
+ -- or when the caller treats it as a semantic attribute.
- -- 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.
+ if Parent (List) = Par_Nod or else Semantic then
+ Visit_List (List);
+ end if;
+ end;
- return;
- end;
- end if;
+ -- Otherwise the field denotes information which does not need to be
+ -- visited (chars, literals, etc.).
- elsif F in List_Range and then Parent (List_Id (F)) = N then
- Visit_List (List_Id (F));
- return;
+ else
+ null;
end if;
end Visit_Field;
-- Visit_Itype --
-----------------
- procedure Visit_Itype (Old_Itype : Entity_Id) is
+ procedure Visit_Itype (Itype : Entity_Id) is
+ New_Assoc : Node_Id;
New_Itype : Entity_Id;
- Ent : Entity_Id;
+ Old_Assoc : Node_Id;
begin
+ pragma Assert (Nkind (Itype) in N_Entity);
+ pragma Assert (Is_Itype (Itype));
+
-- 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
+ if Ekind (Itype) = E_Subprogram_Type then
+ return;
+
+ -- Nothing to do if the itype was already visited
+
+ elsif NCT_Tables_In_Use
+ and then Present (NCT_New_Entities.Get (Itype))
+ then
+ return;
+
+ -- Nothing to do if the associated node of the itype is not within
+ -- the subtree being replicated.
+
+ elsif not In_Subtree
+ (N => Associated_Node_For_Itype (Itype),
+ Root => Source)
+ then
return;
end if;
- New_Itype := New_Copy (Old_Itype);
+ -- Create a new itype by directly copying the old itype. This action
+ -- causes all attributes of the old itype to be inherited.
- -- 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.
+ New_Itype := New_Copy (Itype);
- Set_Chars (New_Itype, New_Internal_Name ('T'));
+ -- Create a new name for the new itype because the back end requires
+ -- distinct names for debugging purposes.
- -- 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.
+ Set_Chars (New_Itype, New_Internal_Name ('T'));
- Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
+ -- Update the Comes_From_Source and Sloc attributes of the itype in
+ -- case the caller has supplied new values.
- if Present (Ent) then
- Set_Associated_Node_For_Itype (New_Itype, Ent);
- end if;
+ Update_CFS_Sloc (New_Itype);
- Ent := NCT_Itype_Assoc.Get (Old_Itype);
+ -- Establish the following mapping within table NCT_New_Entities:
- if Present (Ent) then
- Set_Associated_Node_For_Itype (Ent, New_Itype);
+ -- Itype -> New_Itype
- -- If the hash table has no association for this Itype and its
- -- associated node, enter one now.
+ Add_New_Entity (Itype, New_Itype);
- else
- NCT_Itype_Assoc.Set
- (Associated_Node_For_Itype (Old_Itype), New_Itype);
- end if;
+ -- The new itype must be unfrozen because the resulting subtree may
+ -- be inserted anywhere and cause an earlier or later freezing.
if Present (Freeze_Node (New_Itype)) then
- Set_Is_Frozen (New_Itype, False);
Set_Freeze_Node (New_Itype, Empty);
+ Set_Is_Frozen (New_Itype, False);
end if;
- -- Add new association to map
-
- NCT_Assoc.Set (Old_Itype, New_Itype);
- NCT_Hash_Tables_Used := True;
-
-- If a record subtype is simply copied, the entity list will be
-- shared. Thus cloned_Subtype must be set to indicate the sharing.
+ -- ??? What does this do?
- if Ekind_In (Old_Itype, E_Class_Wide_Subtype, E_Record_Subtype) then
- Set_Cloned_Subtype (New_Itype, Old_Itype);
+ if Ekind_In (Itype, E_Class_Wide_Subtype, E_Record_Subtype) then
+ Set_Cloned_Subtype (New_Itype, Itype);
end if;
- -- Visit descendants that eventually get copied
+ -- The associated node may denote an entity, in which case it may
+ -- already have a new corresponding entity created during a prior
+ -- call to Visit_Entity or Visit_Itype for the same subtree.
- Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype);
+ -- Given
+ -- Old_Assoc ---------> New_Assoc
- if Is_Discrete_Type (Old_Itype) then
- Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype);
+ -- Created by Visit_Itype
+ -- Itype -------------> New_Itype
+ -- ANFI = Old_Assoc ANFI = Old_Assoc < must be updated
- elsif Has_Discriminants (Base_Type (Old_Itype)) then
- -- ??? This should involve call to Visit_Field
- Visit_Elist (Discriminant_Constraint (Old_Itype));
+ -- In the example above, Old_Assoc is an arbitrary entity that was
+ -- already visited for the same subtree and has a corresponding new
+ -- entity New_Assoc. Old_Assoc was inherited by New_Itype by virtue
+ -- of copying entities, however it must be updated to New_Assoc.
- 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;
+ Old_Assoc := Associated_Node_For_Itype (Itype);
- if Is_Packed (Old_Itype) then
- Visit_Field
- (Union_Id (Packed_Array_Impl_Type (Old_Itype)), Old_Itype);
+ if Nkind (Old_Assoc) in N_Entity then
+ if NCT_Tables_In_Use then
+ New_Assoc := NCT_New_Entities.Get (Old_Assoc);
+
+ if Present (New_Assoc) then
+ Set_Associated_Node_For_Itype (New_Itype, New_Assoc);
+ end if;
end if;
+
+ -- Otherwise the associated node denotes a node. Postpone the update
+ -- until Phase 2 when the node is replicated. Establish the following
+ -- mapping within table NCT_Pending_Itypes:
+
+ -- Old_Assoc -> (New_Type, ...)
+
+ else
+ Add_Pending_Itype (Old_Assoc, New_Itype);
end if;
+
+ -- Deal with the semantic fields of itypes. The fields are visited
+ -- because they may mention entities that reside within the subtree
+ -- being copied.
+
+ Visit_Semantic_Fields (Itype);
end Visit_Itype;
----------------
-- Visit_List --
----------------
- procedure Visit_List (L : List_Id) is
- N : Node_Id;
+ procedure Visit_List (List : List_Id) is
+ Elmt : Node_Id;
+
begin
- if L /= No_List then
- N := First (L);
+ -- Note that the element of a syntactic list is always a node, never
+ -- an entity or itype, hence the call to Visit_Node.
+
+ if Present (List) then
+ Elmt := First (List);
+ while Present (Elmt) loop
+ Visit_Node (Elmt);
- while Present (N) loop
- Visit_Node (N);
- Next (N);
+ Next (Elmt);
end loop;
end if;
end Visit_List;
procedure Visit_Node (N : Node_Or_Entity_Id) is
begin
+ pragma Assert (Nkind (N) not in N_Entity);
+
if Nkind (N) = N_Expression_With_Actions then
EWA_Level := EWA_Level + 1;
N_Subprogram_Declaration)
then
EWA_Inner_Scope_Level := EWA_Inner_Scope_Level + 1;
+ end if;
- -- Handle case of an Itype, which must be copied
-
- elsif Nkind (N) in N_Entity 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 descendants in this case.
-
- if Present (NCT_Assoc.Get (Entity_Id (N))) then
- return;
- end if;
-
- Visit_Itype (N);
-
- -- Handle defining entities in Expression_With_Action nodes
-
- elsif Nkind (N) in N_Entity and then EWA_Level > 0 then
-
- -- Nothing to do if already in the hash table
+ Visit_Field
+ (Field => Field1 (N),
+ Par_Nod => N);
- if Present (NCT_Assoc.Get (Entity_Id (N))) then
- return;
- end if;
+ Visit_Field
+ (Field => Field2 (N),
+ Par_Nod => N);
- Visit_Entity (N);
- end if;
+ Visit_Field
+ (Field => Field3 (N),
+ Par_Nod => N);
- -- Visit descendants
+ Visit_Field
+ (Field => Field4 (N),
+ Par_Nod => N);
- 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);
+ Visit_Field
+ (Field => Field5 (N),
+ Par_Nod => N);
if EWA_Level > 0
and then Nkind_In (N, N_Block_Statement,
end if;
end Visit_Node;
+ ---------------------------
+ -- Visit_Semantic_Fields --
+ ---------------------------
+
+ procedure Visit_Semantic_Fields (Id : Entity_Id) is
+ begin
+ pragma Assert (Nkind (Id) in N_Entity);
+
+ -- Discriminant_Constraint
+
+ if Has_Discriminants (Base_Type (Id)) then
+ Visit_Field
+ (Field => Union_Id (Discriminant_Constraint (Id)),
+ Semantic => True);
+ end if;
+
+ -- Etype
+
+ Visit_Field
+ (Field => Union_Id (Etype (Id)),
+ Semantic => True);
+
+ -- First_Index
+ -- Packed_Array_Impl_Type
+
+ if Is_Array_Type (Id) then
+ if Present (First_Index (Id)) then
+ Visit_Field
+ (Field => Union_Id (List_Containing (First_Index (Id))),
+ Semantic => True);
+ end if;
+
+ if Is_Packed (Id) then
+ Visit_Field
+ (Field => Union_Id (Packed_Array_Impl_Type (Id)),
+ Semantic => True);
+ end if;
+ end if;
+
+ -- Scalar_Range
+
+ if Is_Discrete_Type (Id) then
+ Visit_Field
+ (Field => Union_Id (Scalar_Range (Id)),
+ Semantic => True);
+ end if;
+ end Visit_Semantic_Fields;
+
-- Start of processing for New_Copy_Tree
begin
- Build_NCT_Hash_Tables;
+ -- Routine New_Copy_Tree performs a deep copy of a subtree by creating
+ -- shallow copies for each node within, and then updating the child and
+ -- parent pointers accordingly. This process is straightforward, however
+ -- the routine must deal with the following complications:
- -- Hash table set up if required, now start phase one by visiting top
- -- node (we will recursively visit the descendants).
+ -- * Entities defined within N_Expression_With_Actions nodes must be
+ -- replicated rather than shared to avoid introducing two identical
+ -- symbols within the same scope. Note that no other expression can
+ -- currently define entities.
- Visit_Node (Source);
+ -- do
+ -- Source_Low : ...;
+ -- Source_High : ...;
- -- Now the second phase of the copy can start. First we process all the
- -- mapped entities, copying their descendants.
+ -- <reference to Source_Low>
+ -- <reference to Source_High>
+ -- in ... end;
- if NCT_Hash_Tables_Used then
- declare
- Old_E : Entity_Id := Empty;
- New_E : Entity_Id;
+ -- New_Copy_Tree handles this case by first creating new entities
+ -- and then updating all existing references to point to these new
+ -- entities.
- begin
- NCT_Assoc.Get_First (Old_E, New_E);
- while Present (New_E) loop
+ -- do
+ -- New_Low : ...;
+ -- New_High : ...;
- -- Skip entities that were not created in the first phase
- -- (that is, old entities specified by the caller in the set of
- -- mappings to be applied to the tree).
+ -- <reference to New_Low>
+ -- <reference to New_High>
+ -- in ... end;
- if Is_Itype (New_E)
- or else No (Map)
- or else not In_Map (Old_E)
- then
- Copy_Entity_With_Replacement (New_E);
- end if;
+ -- * Itypes defined within the subtree must be replicated to avoid any
+ -- dependencies on invalid or inaccessible data.
- NCT_Assoc.Get_Next (Old_E, New_E);
- end loop;
- end;
+ -- subtype Source_Itype is ... range Source_Low .. Source_High;
+
+ -- New_Copy_Tree handles this case by first creating a new itype in
+ -- the same fashion as entities, and then updating various relevant
+ -- constraints.
+
+ -- subtype New_Itype is ... range New_Low .. New_High;
+
+ -- * The Associated_Node_For_Itype field of itypes must be updated to
+ -- reference the proper replicated entity or node.
+
+ -- * Semantic fields of entities such as Etype and Scope must be
+ -- updated to reference the proper replicated entities.
+
+ -- * Semantic fields of nodes such as First_Real_Statement must be
+ -- updated to reference the proper replicated nodes.
+
+ -- To meet all these demands, routine New_Copy_Tree is split into two
+ -- phases.
+
+ -- Phase 1 traverses the tree in order to locate entities and itypes
+ -- defined within the subtree. New entities are generated and saved in
+ -- table NCT_New_Entities. The semantic fields of all new entities and
+ -- itypes are then updated accordingly.
+
+ -- Phase 2 traverses the tree in order to replicate each node. Various
+ -- semantic fields of nodes and entities are updated accordingly.
+
+ -- Preparatory phase. Clear the contents of tables NCT_New_Entities and
+ -- NCT_Pending_Itypes in case a previous call to New_Copy_Tree left some
+ -- data inside.
+
+ if NCT_Tables_In_Use then
+ NCT_Tables_In_Use := False;
+
+ NCT_New_Entities.Reset;
+ NCT_Pending_Itypes.Reset;
end if;
- -- Now we can copy the actual tree
+ -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with data
+ -- supplied by a linear entity map. The tables offer faster access to
+ -- the same data.
- declare
- Result : constant Node_Id := Copy_Node_With_Replacement (Source);
+ Build_NCT_Tables (Map);
- begin
- if NCT_Hash_Tables_Used then
- NCT_Assoc.Reset;
- NCT_Itype_Assoc.Reset;
- end if;
+ -- Execute Phase 1. Traverse the subtree and generate new entities for
+ -- the following cases:
- return Result;
- end;
+ -- * An entity defined within an N_Expression_With_Actions node
+
+ -- * An itype referenced within the subtree where the associated node
+ -- is also in the subtree.
+
+ -- All new entities are accessible via table NCT_New_Entities, which
+ -- contains mappings of the form:
+
+ -- Old_Entity -> New_Entity
+ -- Old_Itype -> New_Itype
+
+ -- In addition, the associated nodes of all new itypes are mapped in
+ -- table NCT_Pending_Itypes:
+
+ -- Assoc_Nod -> (New_Itype1, New_Itype2, .., New_ItypeN)
+
+ Visit_Any_Node (Source);
+
+ -- Update the semantic attributes of all new entities generated during
+ -- Phase 1 before starting Phase 2. The updates could be performed in
+ -- routine Corresponding_Entity, however this may cause the same entity
+ -- to be updated multiple times, effectively generating useless nodes.
+ -- Keeping the updates separates from Phase 2 ensures that only one set
+ -- of attributes is generated for an entity at any one time.
+
+ Update_New_Entities (Map);
+
+ -- Execute Phase 2. Replicate the source subtree one node at a time.
+ -- The following transformations take place:
+
+ -- * References to entities and itypes are updated to refer to the
+ -- new entities and itypes generated during Phase 1.
+
+ -- * All Associated_Node_For_Itype attributes of itypes are updated
+ -- to refer to the new replicated Associated_Node_For_Itype.
+
+ return Copy_Node_With_Replacement (Source);
end New_Copy_Tree;
-------------------------
N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char);
begin
- Set_Ekind (N, Kind);
- Set_Is_Internal (N, True);
- Append_Entity (N, Scope_Id);
+ Set_Ekind (N, Kind);
+ Set_Is_Internal (N, True);
+ Append_Entity (N, Scope_Id);
if Kind in Type_Kind then
Init_Size_Align (N);
N := Next (Actual_Id);
if Nkind (N) = N_Parameter_Association then
- return First_Named_Actual (Parent (Actual_Id));
+
+ -- In case of a build-in-place call, the call will no longer be a
+ -- call; it will have been rewritten.
+
+ if Nkind_In (Parent (Actual_Id), N_Entry_Call_Statement,
+ N_Function_Call,
+ N_Procedure_Call_Statement)
+ then
+ return First_Named_Actual (Parent (Actual_Id));
+ else
+ return Empty;
+ end if;
else
return N;
end if;
Actual_Id := Next_Actual (Actual_Id);
end Next_Actual;
+ -----------------
+ -- Next_Global --
+ -----------------
+
+ function Next_Global (Node : Node_Id) return Node_Id is
+ begin
+ -- The global item may either be in a list, or by itself, in which case
+ -- there is no next global item with the same mode.
+
+ if Is_List_Member (Node) then
+ return Next (Node);
+ else
+ return Empty;
+ end if;
+ end Next_Global;
+
+ procedure Next_Global (Node : in out Node_Id) is
+ begin
+ Node := Next_Global (Node);
+ end Next_Global;
+
----------------------------------
-- New_Requires_Transient_Scope --
----------------------------------
return False;
end Null_To_Null_Address_Convert_OK;
+ ---------------------------------
+ -- Number_Of_Elements_In_Array --
+ ---------------------------------
+
+ function Number_Of_Elements_In_Array (T : Entity_Id) return Int is
+ Indx : Node_Id;
+ Typ : Entity_Id;
+ Low : Node_Id;
+ High : Node_Id;
+ Num : Int := 1;
+
+ begin
+ pragma Assert (Is_Array_Type (T));
+
+ Indx := First_Index (T);
+ while Present (Indx) loop
+ Typ := Underlying_Type (Etype (Indx));
+
+ -- Never look at junk bounds of a generic type
+
+ if Is_Generic_Type (Typ) then
+ return 0;
+ end if;
+
+ -- Check the array bounds are known at compile time and return zero
+ -- if they are not.
+
+ Low := Type_Low_Bound (Typ);
+ High := Type_High_Bound (Typ);
+
+ if not Compile_Time_Known_Value (Low) then
+ return 0;
+ elsif not Compile_Time_Known_Value (High) then
+ return 0;
+ else
+ Num :=
+ Num * UI_To_Int ((Expr_Value (High) - Expr_Value (Low) + 1));
+ end if;
+
+ Next_Index (Indx);
+ end loop;
+
+ return Num;
+ end Number_Of_Elements_In_Array;
+
-------------------------
-- Object_Access_Level --
-------------------------
-- This construct appears in the context of dispatching calls.
function Reference_To (Obj : Node_Id) return Node_Id;
- -- An explicit dereference is created when removing side-effects from
+ -- An explicit dereference is created when removing side effects from
-- expressions for constraint checking purposes. In this case a local
-- access type is created for it. The correct access level is that of
-- the original source node. We detect this case by noting that the
(Nearest_Dynamic_Scope
(Defining_Entity (Node_Par)));
+ -- For a return statement within a function, return
+ -- the depth of the function itself. This is not just
+ -- a small optimization, but matters when analyzing
+ -- the expression in an expression function before
+ -- the body is created.
+
+ when N_Simple_Return_Statement =>
+ if Ekind (Current_Scope) = E_Function then
+ return Scope_Depth (Current_Scope);
+ end if;
+
when others =>
null;
end case;
-- Scope_Within --
------------------
- function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is
- Scop : Entity_Id;
+ function Scope_Within
+ (Inner : Entity_Id;
+ Outer : Entity_Id) return Boolean
+ is
+ Curr : Entity_Id;
begin
- Scop := Scope1;
- while Scop /= Standard_Standard loop
- Scop := Scope (Scop);
+ Curr := Inner;
+ while Present (Curr) and then Curr /= Standard_Standard loop
+ Curr := Scope (Curr);
- if Scop = Scope2 then
+ if Curr = Outer then
return True;
end if;
end loop;
-- Scope_Within_Or_Same --
--------------------------
- function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is
- Scop : Entity_Id;
+ function Scope_Within_Or_Same
+ (Inner : Entity_Id;
+ Outer : Entity_Id) return Boolean
+ is
+ Curr : Entity_Id;
begin
- Scop := Scope1;
- while Scop /= Standard_Standard loop
- if Scop = Scope2 then
+ Curr := Inner;
+ while Present (Curr) and then Curr /= Standard_Standard loop
+ if Curr = Outer then
return True;
- else
- Scop := Scope (Scop);
end if;
+
+ Curr := Scope (Curr);
end loop;
return False;
and then Is_Access_Subprogram_Type (Base_Type (E))
and then Has_Foreign_Convention (E)
then
-
- -- A pragma Convention in an instance may apply to the subtype
- -- created for a formal, in which case we have already verified
- -- that conventions of actual and formal match and there is nothing
- -- to flag on the subtype.
-
- if In_Instance then
- null;
- else
- Set_Can_Use_Internal_Rep (E, False);
- end if;
+ Set_Can_Use_Internal_Rep (E, False);
end if;
- -- If E is an object or component, and the type of E is an anonymous
- -- access type with no convention set, then also set the convention of
- -- the anonymous access type. We do not do this for anonymous protected
- -- types, since protected types always have the default convention.
+ -- If E is an object, including a component, and the type of E is an
+ -- anonymous access type with no convention set, then also set the
+ -- convention of the anonymous access type. We do not do this for
+ -- anonymous protected types, since protected types always have the
+ -- default convention.
if Present (Etype (E))
and then (Is_Object (E)
- or else Ekind (E) = E_Component
-- Allow E_Void (happens for pragma Convention appearing
-- in the middle of a record applying to a component)
Set_Has_Convention_Pragma (Typ);
-- And for the access subprogram type, deal similarly with the
- -- designated E_Subprogram_Type if it is also internal (which
- -- it always is?)
+ -- designated E_Subprogram_Type, which is always internal.
if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then
declare
Dtype : constant Entity_Id := Designated_Type (Typ);
begin
if Ekind (Dtype) = E_Subprogram_Type
- and then Is_Itype (Dtype)
and then not Has_Convention_Pragma (Dtype)
then
Basic_Set_Convention (Dtype, Val);
end if;
end Set_Referenced_Modified;
+ ------------------
+ -- Set_Rep_Info --
+ ------------------
+
+ procedure Set_Rep_Info (T1 : Entity_Id; T2 : Entity_Id) is
+ begin
+ Set_Is_Atomic (T1, Is_Atomic (T2));
+ Set_Is_Independent (T1, Is_Independent (T2));
+ Set_Is_Volatile_Full_Access (T1, Is_Volatile_Full_Access (T2));
+
+ if Is_Base_Type (T1) then
+ Set_Is_Volatile (T1, Is_Volatile (T2));
+ end if;
+ end Set_Rep_Info;
+
----------------------------
-- Set_Scope_Is_Transient --
----------------------------
end if;
end Subprogram_Access_Level;
+ ---------------------
+ -- Subprogram_Name --
+ ---------------------
+
+ function Subprogram_Name (N : Node_Id) return String is
+ Buf : Bounded_String;
+ Ent : Node_Id := N;
+ Nod : Node_Id;
+
+ begin
+ while Present (Ent) loop
+ case Nkind (Ent) is
+ when N_Subprogram_Body =>
+ Ent := Defining_Unit_Name (Specification (Ent));
+ exit;
+
+ when N_Subprogram_Declaration =>
+ Nod := Corresponding_Body (Ent);
+
+ if Present (Nod) then
+ Ent := Nod;
+ else
+ Ent := Defining_Unit_Name (Specification (Ent));
+ end if;
+
+ exit;
+
+ when N_Subprogram_Instantiation
+ | N_Package_Body
+ | N_Package_Specification
+ =>
+ Ent := Defining_Unit_Name (Ent);
+ exit;
+
+ when N_Protected_Type_Declaration =>
+ Ent := Corresponding_Body (Ent);
+ exit;
+
+ when N_Protected_Body
+ | N_Task_Body
+ =>
+ Ent := Defining_Identifier (Ent);
+ exit;
+
+ when others =>
+ null;
+ end case;
+
+ Ent := Parent (Ent);
+ end loop;
+
+ if No (Ent) then
+ return "unknown subprogram:unknown file:0:0";
+ end if;
+
+ -- If the subprogram is a child unit, use its simple name to start the
+ -- construction of the fully qualified name.
+
+ if Nkind (Ent) = N_Defining_Program_Unit_Name then
+ Ent := Defining_Identifier (Ent);
+ end if;
+
+ Append_Entity_Name (Buf, Ent);
+
+ -- Append homonym number if needed
+
+ if Nkind (N) in N_Entity and then Has_Homonym (N) then
+ declare
+ H : Entity_Id := Homonym (N);
+ Nr : Nat := 1;
+
+ begin
+ while Present (H) loop
+ if Scope (H) = Scope (N) then
+ Nr := Nr + 1;
+ end if;
+
+ H := Homonym (H);
+ end loop;
+
+ if Nr > 1 then
+ Append (Buf, '#');
+ Append (Buf, Nr);
+ end if;
+ end;
+ end if;
+
+ -- Append source location of Ent to Buf so that the string will
+ -- look like "subp:file:line:col".
+
+ declare
+ Loc : constant Source_Ptr := Sloc (Ent);
+ begin
+ Append (Buf, ':');
+ Append (Buf, Reference_Name (Get_Source_File_Index (Loc)));
+ Append (Buf, ':');
+ Append (Buf, Nat (Get_Logical_Line_Number (Loc)));
+ Append (Buf, ':');
+ Append (Buf, Nat (Get_Column_Number (Loc)));
+ end;
+
+ return +Buf;
+ end Subprogram_Name;
+
-------------------------------
-- Support_Atomic_Primitives --
-------------------------------
return Scope_Within_Or_Same (Scope (E), S);
end Within_Scope;
+ ----------------------------
+ -- Within_Subprogram_Call --
+ ----------------------------
+
+ function Within_Subprogram_Call (N : Node_Id) return Boolean is
+ Par : Node_Id;
+
+ begin
+ -- Climb the parent chain looking for a function or procedure call
+
+ Par := N;
+ while Present (Par) loop
+ if Nkind_In (Par, N_Entry_Call_Statement,
+ N_Function_Call,
+ N_Procedure_Call_Statement)
+ then
+ return True;
+
+ -- Prevent the search from going too far
+
+ elsif Is_Body_Or_Package_Declaration (Par) then
+ exit;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ return False;
+ end Within_Subprogram_Call;
+
----------------
-- Wrong_Type --
----------------
end if;
end Yields_Universal_Type;
+begin
+ Erroutc.Subprogram_Name_Ptr := Subprogram_Name'Access;
end Sem_Util;
git://gcc.gnu.org / gcc.git / blobdiff