+ -- Handle synchronized interface derivations
+
+ if Is_Concurrent_Record_Type (Typ) then
+ declare
+ Iface_List : constant List_Id := Abstract_Interface_List (Typ);
+ begin
+ if Is_Non_Empty_List (Iface_List) then
+ Find_Tag (Etype (First (Iface_List)));
+ end if;
+ end;
+
+ -- Climb to the root type handling private types
+
+ elsif Present (Full_View (Etype (Typ))) then
+ if Full_View (Etype (Typ)) /= Typ then
+ Find_Tag (Full_View (Etype (Typ)));
+ end if;
+
+ elsif Etype (Typ) /= Typ then
+ Find_Tag (Etype (Typ));
+ end if;
+
+ -- Traverse the list of interfaces implemented by the type
+
+ if not Found
+ and then Present (Abstract_Interfaces (Typ))
+ and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
+ then
+ -- Skip the tag associated with the primary table
+
+ if not Is_Sync_Typ then
+ pragma Assert
+ (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+ AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
+ pragma Assert (Present (AI_Tag));
+ end if;
+
+ AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
+ while Present (AI_Elmt) loop
+ AI := Node (AI_Elmt);
+
+ if AI = Iface or else Is_Ancestor (Iface, AI) then
+ Found := True;
+ return;
+ end if;
+
+ AI_Tag := Next_Tag_Component (AI_Tag);
+ Next_Elmt (AI_Elmt);
+ end loop;
+ end if;
+ end Find_Tag;
+
+ -- Start of processing for Find_Interface_Tag
+
+ begin
+ pragma Assert (Is_Interface (Iface));
+
+ -- Handle private types
+
+ if Has_Private_Declaration (Typ)
+ and then Present (Full_View (Typ))
+ then
+ Typ := Full_View (Typ);
+ end if;
+
+ -- Handle access types
+
+ if Is_Access_Type (Typ) then
+ Typ := Directly_Designated_Type (Typ);
+ end if;
+
+ -- Handle task and protected types implementing interfaces
+
+ if Is_Concurrent_Type (Typ) then
+ Typ := Corresponding_Record_Type (Typ);
+ end if;
+
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Etype (Typ);
+ end if;
+
+ -- Handle entities from the limited view
+
+ if Ekind (Typ) = E_Incomplete_Type then
+ pragma Assert (Present (Non_Limited_View (Typ)));
+ Typ := Non_Limited_View (Typ);
+ end if;
+
+ if not Is_Concurrent_Record_Type (Typ) then
+ Find_Tag (Typ);
+ pragma Assert (Found);
+ return AI_Tag;
+
+ -- Concurrent record types
+
+ else
+ Is_Sync_Typ := True;
+ AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
+ Find_Tag (Typ);
+ pragma Assert (Found);
+
+ if Is_Primary_Tag then
+ return First_Tag_Component (Typ);
+ else
+ return AI_Tag;
+ end if;
+ end if;
+ end Find_Interface_Tag;
+
+ --------------------
+ -- Find_Interface --
+ --------------------
+
+ function Find_Interface
+ (T : Entity_Id;
+ Comp : Entity_Id) return Entity_Id
+ is
+ AI_Tag : Entity_Id;
+ Found : Boolean := False;
+ Iface : Entity_Id;
+ Typ : Entity_Id := T;
+
+ Is_Sync_Typ : Boolean := False;
+ -- In case of non concurrent-record-types each parent-type has the
+ -- tags associated with the interface types that are not implemented
+ -- by the ancestors; concurrent-record-types have their whole list of
+ -- interface tags (and this case requires some special management).
+
+ procedure Find_Iface (Typ : Entity_Id);
+ -- Internal subprogram used to recursively climb to the ancestors
+
+ ----------------
+ -- Find_Iface --
+ ----------------
+
+ procedure Find_Iface (Typ : Entity_Id) is
+ AI_Elmt : Elmt_Id;
+
+ begin
+ -- Climb to the root type
+
+ -- Handle sychronized interface derivations
+
+ if Is_Concurrent_Record_Type (Typ) then
+ declare
+ Iface_List : constant List_Id := Abstract_Interface_List (Typ);
+ begin
+ if Is_Non_Empty_List (Iface_List) then
+ Find_Iface (Etype (First (Iface_List)));
+ end if;
+ end;
+
+ -- Handle the common case
+
+ elsif Etype (Typ) /= Typ then
+ pragma Assert (not Present (Full_View (Etype (Typ))));
+ Find_Iface (Etype (Typ));
+ end if;
+
+ -- Traverse the list of interfaces implemented by the type
+
+ if not Found
+ and then Present (Abstract_Interfaces (Typ))
+ and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
+ then
+ -- Skip the tag associated with the primary table
+
+ if not Is_Sync_Typ then
+ pragma Assert
+ (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+ AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
+ pragma Assert (Present (AI_Tag));
+ end if;
+
+ AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
+ while Present (AI_Elmt) loop
+ if AI_Tag = Comp then
+ Iface := Node (AI_Elmt);
+ Found := True;
+ return;
+ end if;
+
+ AI_Tag := Next_Tag_Component (AI_Tag);
+ Next_Elmt (AI_Elmt);
+ end loop;
+ end if;
+ end Find_Iface;
+
+ -- Start of processing for Find_Interface
+
+ begin
+ -- Handle private types
+
+ if Has_Private_Declaration (Typ)
+ and then Present (Full_View (Typ))
+ then
+ Typ := Full_View (Typ);
+ end if;
+
+ -- Handle access types
+
+ if Is_Access_Type (Typ) then
+ Typ := Directly_Designated_Type (Typ);
+ end if;
+
+ -- Handle task and protected types implementing interfaces
+
+ if Is_Concurrent_Type (Typ) then
+ Typ := Corresponding_Record_Type (Typ);
+ end if;
+
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Etype (Typ);
+ end if;
+
+ -- Handle entities from the limited view
+
+ if Ekind (Typ) = E_Incomplete_Type then
+ pragma Assert (Present (Non_Limited_View (Typ)));
+ Typ := Non_Limited_View (Typ);
+ end if;
+
+ if Is_Concurrent_Record_Type (Typ) then
+ Is_Sync_Typ := True;
+ AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
+ end if;
+
+ Find_Iface (Typ);
+ pragma Assert (Found);
+ return Iface;
+ end Find_Interface;
+
+ ------------------
+ -- Find_Prim_Op --
+ ------------------
+
+ function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id is
+ Prim : Elmt_Id;
+ Typ : Entity_Id := T;
+ Op : Entity_Id;
+
+ begin
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Root_Type (Typ);
+ end if;
+
+ Typ := Underlying_Type (Typ);
+
+ -- Loop through primitive operations
+
+ Prim := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim) loop
+ Op := Node (Prim);
+
+ -- We can retrieve primitive operations by name if it is an internal
+ -- name. For equality we must check that both of its operands have
+ -- the same type, to avoid confusion with user-defined equalities
+ -- than may have a non-symmetric signature.
+
+ exit when Chars (Op) = Name
+ and then
+ (Name /= Name_Op_Eq
+ or else Etype (First_Entity (Op)) = Etype (Last_Entity (Op)));
+
+ Next_Elmt (Prim);
+ pragma Assert (Present (Prim));
+ end loop;
+
+ return Node (Prim);
+ end Find_Prim_Op;
+
+ ------------------
+ -- Find_Prim_Op --
+ ------------------
+
+ function Find_Prim_Op
+ (T : Entity_Id;
+ Name : TSS_Name_Type) return Entity_Id
+ is
+ Prim : Elmt_Id;
+ Typ : Entity_Id := T;
+
+ begin
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Root_Type (Typ);
+ end if;
+
+ Typ := Underlying_Type (Typ);
+
+ Prim := First_Elmt (Primitive_Operations (Typ));
+ while not Is_TSS (Node (Prim), Name) loop
+ Next_Elmt (Prim);
+ pragma Assert (Present (Prim));
+ end loop;
+
+ return Node (Prim);
+ end Find_Prim_Op;
+
+ ----------------------
+ -- Force_Evaluation --
+ ----------------------
+
+ procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False) is
+ begin
+ Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
+ end Force_Evaluation;
+
+ ------------------------
+ -- Generate_Poll_Call --
+ ------------------------
+
+ procedure Generate_Poll_Call (N : Node_Id) is
+ begin
+ -- No poll call if polling not active
+
+ if not Polling_Required then
+ return;
+
+ -- Otherwise generate require poll call
+
+ else
+ Insert_Before_And_Analyze (N,
+ Make_Procedure_Call_Statement (Sloc (N),
+ Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N))));
+ end if;
+ end Generate_Poll_Call;
+
+ ---------------------------------
+ -- Get_Current_Value_Condition --
+ ---------------------------------
+
+ -- Note: the implementation of this procedure is very closely tied to the
+ -- implementation of Set_Current_Value_Condition. In the Get procedure, we
+ -- interpret Current_Value fields set by the Set procedure, so the two
+ -- procedures need to be closely coordinated.
+
+ procedure Get_Current_Value_Condition
+ (Var : Node_Id;
+ Op : out Node_Kind;
+ Val : out Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Var);
+ Ent : constant Entity_Id := Entity (Var);
+
+ procedure Process_Current_Value_Condition
+ (N : Node_Id;
+ S : Boolean);
+ -- N is an expression which holds either True (S = True) or False (S =
+ -- False) in the condition. This procedure digs out the expression and
+ -- if it refers to Ent, sets Op and Val appropriately.
+
+ -------------------------------------
+ -- Process_Current_Value_Condition --
+ -------------------------------------
+
+ procedure Process_Current_Value_Condition
+ (N : Node_Id;
+ S : Boolean)
+ is
+ Cond : Node_Id;
+ Sens : Boolean;
+
+ begin
+ Cond := N;
+ Sens := S;
+
+ -- Deal with NOT operators, inverting sense
+
+ while Nkind (Cond) = N_Op_Not loop
+ Cond := Right_Opnd (Cond);
+ Sens := not Sens;
+ end loop;
+
+ -- Deal with AND THEN and AND cases
+
+ if Nkind (Cond) = N_And_Then
+ or else Nkind (Cond) = N_Op_And
+ then
+ -- Don't ever try to invert a condition that is of the form
+ -- of an AND or AND THEN (since we are not doing sufficiently
+ -- general processing to allow this).
+
+ if Sens = False then
+ Op := N_Empty;
+ Val := Empty;
+ return;
+ end if;
+
+ -- Recursively process AND and AND THEN branches
+
+ Process_Current_Value_Condition (Left_Opnd (Cond), True);
+
+ if Op /= N_Empty then
+ return;
+ end if;
+
+ Process_Current_Value_Condition (Right_Opnd (Cond), True);
+ return;
+
+ -- Case of relational operator
+
+ elsif Nkind (Cond) in N_Op_Compare then
+ Op := Nkind (Cond);
+
+ -- Invert sense of test if inverted test
+
+ if Sens = False then
+ case Op is
+ when N_Op_Eq => Op := N_Op_Ne;
+ when N_Op_Ne => Op := N_Op_Eq;
+ when N_Op_Lt => Op := N_Op_Ge;
+ when N_Op_Gt => Op := N_Op_Le;
+ when N_Op_Le => Op := N_Op_Gt;
+ when N_Op_Ge => Op := N_Op_Lt;
+ when others => raise Program_Error;
+ end case;
+ end if;
+
+ -- Case of entity op value
+
+ if Is_Entity_Name (Left_Opnd (Cond))
+ and then Ent = Entity (Left_Opnd (Cond))
+ and then Compile_Time_Known_Value (Right_Opnd (Cond))
+ then
+ Val := Right_Opnd (Cond);
+
+ -- Case of value op entity
+
+ elsif Is_Entity_Name (Right_Opnd (Cond))
+ and then Ent = Entity (Right_Opnd (Cond))
+ and then Compile_Time_Known_Value (Left_Opnd (Cond))
+ then
+ Val := Left_Opnd (Cond);
+
+ -- We are effectively swapping operands
+
+ case Op is
+ when N_Op_Eq => null;
+ when N_Op_Ne => null;
+ when N_Op_Lt => Op := N_Op_Gt;
+ when N_Op_Gt => Op := N_Op_Lt;
+ when N_Op_Le => Op := N_Op_Ge;
+ when N_Op_Ge => Op := N_Op_Le;
+ when others => raise Program_Error;
+ end case;
+
+ else
+ Op := N_Empty;
+ end if;
+
+ return;
+
+ -- Case of Boolean variable reference, return as though the
+ -- reference had said var = True.
+
+ else
+ if Is_Entity_Name (Cond)
+ and then Ent = Entity (Cond)
+ then
+ Val := New_Occurrence_Of (Standard_True, Sloc (Cond));
+
+ if Sens = False then
+ Op := N_Op_Ne;
+ else
+ Op := N_Op_Eq;
+ end if;
+ end if;
+ end if;
+ end Process_Current_Value_Condition;
+
+ -- Start of processing for Get_Current_Value_Condition
+
+ begin
+ Op := N_Empty;
+ Val := Empty;
+
+ -- Immediate return, nothing doing, if this is not an object
+
+ if Ekind (Ent) not in Object_Kind then
+ return;
+ end if;
+
+ -- Otherwise examine current value
+
+ declare
+ CV : constant Node_Id := Current_Value (Ent);
+ Sens : Boolean;
+ Stm : Node_Id;
+
+ begin
+ -- If statement. Condition is known true in THEN section, known False
+ -- in any ELSIF or ELSE part, and unknown outside the IF statement.
+
+ if Nkind (CV) = N_If_Statement then
+
+ -- Before start of IF statement
+
+ if Loc < Sloc (CV) then
+ return;
+
+ -- After end of IF statement
+
+ elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
+ return;
+ end if;
+
+ -- At this stage we know that we are within the IF statement, but
+ -- unfortunately, the tree does not record the SLOC of the ELSE so
+ -- we cannot use a simple SLOC comparison to distinguish between
+ -- the then/else statements, so we have to climb the tree.
+
+ declare
+ N : Node_Id;
+
+ begin
+ N := Parent (Var);
+ while Parent (N) /= CV loop
+ N := Parent (N);
+
+ -- If we fall off the top of the tree, then that's odd, but
+ -- perhaps it could occur in some error situation, and the
+ -- safest response is simply to assume that the outcome of
+ -- the condition is unknown. No point in bombing during an
+ -- attempt to optimize things.
+
+ if No (N) then
+ return;
+ end if;
+ end loop;
+
+ -- Now we have N pointing to a node whose parent is the IF
+ -- statement in question, so now we can tell if we are within
+ -- the THEN statements.
+
+ if Is_List_Member (N)
+ and then List_Containing (N) = Then_Statements (CV)
+ then
+ Sens := True;
+
+ -- If the variable reference does not come from source, we
+ -- cannot reliably tell whether it appears in the else part.
+ -- In particular, if if appears in generated code for a node
+ -- that requires finalization, it may be attached to a list
+ -- that has not been yet inserted into the code. For now,
+ -- treat it as unknown.
+
+ elsif not Comes_From_Source (N) then
+ return;
+
+ -- Otherwise we must be in ELSIF or ELSE part
+
+ else
+ Sens := False;
+ end if;
+ end;
+
+ -- ELSIF part. Condition is known true within the referenced
+ -- ELSIF, known False in any subsequent ELSIF or ELSE part, and
+ -- unknown before the ELSE part or after the IF statement.
+
+ elsif Nkind (CV) = N_Elsif_Part then
+ Stm := Parent (CV);
+
+ -- Before start of ELSIF part
+
+ if Loc < Sloc (CV) then
+ return;
+
+ -- After end of IF statement
+
+ elsif Loc >= Sloc (Stm) +
+ Text_Ptr (UI_To_Int (End_Span (Stm)))
+ then
+ return;
+ end if;
+
+ -- Again we lack the SLOC of the ELSE, so we need to climb the
+ -- tree to see if we are within the ELSIF part in question.
+
+ declare
+ N : Node_Id;
+
+ begin
+ N := Parent (Var);
+ while Parent (N) /= Stm loop
+ N := Parent (N);
+
+ -- If we fall off the top of the tree, then that's odd, but
+ -- perhaps it could occur in some error situation, and the
+ -- safest response is simply to assume that the outcome of
+ -- the condition is unknown. No point in bombing during an
+ -- attempt to optimize things.
+
+ if No (N) then
+ return;
+ end if;
+ end loop;
+
+ -- Now we have N pointing to a node whose parent is the IF
+ -- statement in question, so see if is the ELSIF part we want.
+ -- the THEN statements.
+
+ if N = CV then
+ Sens := True;
+
+ -- Otherwise we must be in susbequent ELSIF or ELSE part
+
+ else
+ Sens := False;
+ end if;
+ end;
+
+ -- Iteration scheme of while loop. The condition is known to be
+ -- true within the body of the loop.
+
+ elsif Nkind (CV) = N_Iteration_Scheme then
+ declare
+ Loop_Stmt : constant Node_Id := Parent (CV);
+
+ begin
+ -- Before start of body of loop
+
+ if Loc < Sloc (Loop_Stmt) then
+ return;
+
+ -- After end of LOOP statement
+
+ elsif Loc >= Sloc (End_Label (Loop_Stmt)) then
+ return;
+
+ -- We are within the body of the loop
+
+ else
+ Sens := True;
+ end if;
+ end;
+
+ -- All other cases of Current_Value settings
+
+ else
+ return;
+ end if;
+
+ -- If we fall through here, then we have a reportable condition, Sens
+ -- is True if the condition is true and False if it needs inverting.
+
+ Process_Current_Value_Condition (Condition (CV), Sens);
+ end;
+ end Get_Current_Value_Condition;
+
+ ---------------------------------
+ -- Has_Controlled_Coextensions --
+ ---------------------------------
+
+ function Has_Controlled_Coextensions (Typ : Entity_Id) return Boolean is
+ D_Typ : Entity_Id;
+ Discr : Entity_Id;
+
+ begin
+ -- Only consider record types
+
+ if Ekind (Typ) /= E_Record_Type
+ and then Ekind (Typ) /= E_Record_Subtype
+ then
+ return False;
+ end if;
+
+ if Has_Discriminants (Typ) then
+ Discr := First_Discriminant (Typ);
+ while Present (Discr) loop
+ D_Typ := Etype (Discr);
+
+ if Ekind (D_Typ) = E_Anonymous_Access_Type
+ and then
+ (Is_Controlled (Directly_Designated_Type (D_Typ))
+ or else
+ Is_Concurrent_Type (Directly_Designated_Type (D_Typ)))
+ then
+ return True;
+ end if;
+
+ Next_Discriminant (Discr);
+ end loop;
+ end if;
+
+ return False;
+ end Has_Controlled_Coextensions;
+
+ --------------------
+ -- Homonym_Number --
+ --------------------
+
+ function Homonym_Number (Subp : Entity_Id) return Nat is
+ Count : Nat;
+ Hom : Entity_Id;
+
+ begin
+ Count := 1;
+ Hom := Homonym (Subp);
+ while Present (Hom) loop
+ if Scope (Hom) = Scope (Subp) then
+ Count := Count + 1;
+ end if;
+
+ Hom := Homonym (Hom);
+ end loop;
+
+ return Count;
+ end Homonym_Number;
+
+ ------------------------------
+ -- In_Unconditional_Context --
+ ------------------------------
+
+ function In_Unconditional_Context (Node : Node_Id) return Boolean is
+ P : Node_Id;
+
+ begin
+ P := Node;
+ while Present (P) loop
+ case Nkind (P) is
+ when N_Subprogram_Body =>
+ return True;
+
+ when N_If_Statement =>
+ return False;
+
+ when N_Loop_Statement =>
+ return False;
+
+ when N_Case_Statement =>
+ return False;
+
+ when others =>
+ P := Parent (P);
+ end case;
+ end loop;
+
+ return False;
+ end In_Unconditional_Context;
+
+ -------------------
+ -- Insert_Action --
+ -------------------
+
+ procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is
+ begin
+ if Present (Ins_Action) then
+ Insert_Actions (Assoc_Node, New_List (Ins_Action));
+ end if;
+ end Insert_Action;
+
+ -- Version with check(s) suppressed
+
+ procedure Insert_Action
+ (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id)
+ is
+ begin
+ Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress);
+ end Insert_Action;
+
+ --------------------
+ -- Insert_Actions --
+ --------------------
+
+ procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is
+ N : Node_Id;
+ P : Node_Id;
+
+ Wrapped_Node : Node_Id := Empty;
+
+ begin
+ if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
+ return;
+ end if;
+
+ -- Ignore insert of actions from inside default expression in the
+ -- special preliminary analyze mode. Any insertions at this point
+ -- have no relevance, since we are only doing the analyze to freeze
+ -- the types of any static expressions. See section "Handling of
+ -- Default Expressions" in the spec of package Sem for further details.
+
+ if In_Default_Expression then
+ return;
+ end if;
+
+ -- If the action derives from stuff inside a record, then the actions