- -- If the interface type is implemented, then the matching type
- -- in the primitive should be the implementing record type.
-
- if Ekind (Iface_Typ) = E_Record_Type
- and then Is_Interface (Iface_Typ)
- and then Is_Implemented (Iface_Typ)
- then
- if Prim_Typ /= Tag_Typ then
- return False;
- end if;
-
- -- The two parameters must be both mode and subtype conformant
-
- elsif Ekind (Iface_Id) /= Ekind (Prim_Id)
- or else
- not Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant)
- then
- return False;
- end if;
-
- Next (Iface_Param);
- Next (Prim_Param);
- end loop;
-
- -- One of the two lists contains more parameters than the other
-
- if Present (Iface_Param) or else Present (Prim_Param) then
- return False;
- end if;
-
- return True;
- end Matches_Prefixed_View_Profile;
-
- -- Start of processing for Find_Overridden_Synchronized_Primitive
-
- begin
- -- At this point the caller should have collected the interfaces
- -- implemented by the synchronized type.
-
- pragma Assert (Present (Ifaces_List));
-
- -- Find the tagged type to which subprogram Def_Id is primitive. If the
- -- subprogram was declared within a protected or a task type, the type
- -- is the scope itself, otherwise it is the type of the first parameter.
-
- if In_Scope then
- Tag_Typ := Scope (Def_Id);
-
- elsif Present (First_Formal (Def_Id)) then
- Tag_Typ := Find_Parameter_Type (Parent (First_Formal (Def_Id)));
-
- -- A parameterless subprogram which is declared outside a synchronized
- -- type cannot act as a primitive, thus it cannot override anything.
-
- else
- return Empty;
- end if;
-
- -- Traverse the homonym chain, looking at a potentially overriden
- -- subprogram that belongs to an implemented interface.
-
- Hom := First_Hom;
- while Present (Hom) loop
- Subp := Hom;
-
- -- Entries can override abstract or null interface procedures
-
- if Ekind (Def_Id) = E_Entry
- and then Ekind (Subp) = E_Procedure
- and then Nkind (Parent (Subp)) = N_Procedure_Specification
- and then (Is_Abstract_Subprogram (Subp)
- or else Null_Present (Parent (Subp)))
- then
- while Present (Alias (Subp)) loop
- Subp := Alias (Subp);
- end loop;
-
- if Matches_Prefixed_View_Profile
- (Parameter_Specifications (Parent (Def_Id)),
- Parameter_Specifications (Parent (Subp)))
- then
- Candidate := Subp;
-
- -- Absolute match
-
- if Has_Correct_Formal_Mode (Candidate) then
- return Candidate;
- end if;
- end if;
-
- -- Procedures can override abstract or null interface procedures
-
- elsif Ekind (Def_Id) = E_Procedure
- and then Ekind (Subp) = E_Procedure
- and then Nkind (Parent (Subp)) = N_Procedure_Specification
- and then (Is_Abstract_Subprogram (Subp)
- or else Null_Present (Parent (Subp)))
- and then Matches_Prefixed_View_Profile
- (Parameter_Specifications (Parent (Def_Id)),
- Parameter_Specifications (Parent (Subp)))
- then
- Candidate := Subp;
-
- -- Absolute match
-
- if Has_Correct_Formal_Mode (Candidate) then
- return Candidate;
- end if;
-
- -- Functions can override abstract interface functions
-
- elsif Ekind (Def_Id) = E_Function
- and then Ekind (Subp) = E_Function
- and then Nkind (Parent (Subp)) = N_Function_Specification
- and then Is_Abstract_Subprogram (Subp)
- and then Matches_Prefixed_View_Profile
- (Parameter_Specifications (Parent (Def_Id)),
- Parameter_Specifications (Parent (Subp)))
- and then Etype (Result_Definition (Parent (Def_Id))) =
- Etype (Result_Definition (Parent (Subp)))
- then
- return Subp;
- end if;
-
- Hom := Homonym (Hom);
- end loop;
-
- -- After examining all candidates for overriding, we are left with
- -- the best match which is a mode incompatible interface routine.
- -- Do not emit an error if the Expander is active since this error
- -- will be detected later on after all concurrent types are expanded
- -- and all wrappers are built. This check is meant for spec-only
- -- compilations.
-
- if Present (Candidate)
- and then not Expander_Active
- then
- Iface_Typ := Find_Parameter_Type (Parent (First_Formal (Candidate)));
-
- -- Def_Id is primitive of a protected type, declared inside the type,
- -- and the candidate is primitive of a limited or synchronized
- -- interface.
-
- if In_Scope
- and then Is_Protected_Type (Tag_Typ)
- and then
- (Is_Limited_Interface (Iface_Typ)
- or else Is_Protected_Interface (Iface_Typ)
- or else Is_Synchronized_Interface (Iface_Typ)
- or else Is_Task_Interface (Iface_Typ))
- then
- -- Must reword this message, comma before to in -gnatj mode ???
-
- Error_Msg_NE
- ("first formal of & must be of mode `OUT`, `IN OUT` or " &
- "access-to-variable", Tag_Typ, Candidate);
- Error_Msg_N
- ("\to be overridden by protected procedure or entry " &
- "(RM 9.4(11.9/2))", Tag_Typ);
- end if;
- end if;
-
- return Candidate;
- end Find_Overridden_Synchronized_Primitive;
-
- -----------------------------
- -- Find_Static_Alternative --
- -----------------------------
-
- function Find_Static_Alternative (N : Node_Id) return Node_Id is
- Expr : constant Node_Id := Expression (N);
- Val : constant Uint := Expr_Value (Expr);
- Alt : Node_Id;
- Choice : Node_Id;
-
- begin
- Alt := First (Alternatives (N));
-
- Search : loop
- if Nkind (Alt) /= N_Pragma then
- Choice := First (Discrete_Choices (Alt));
- while Present (Choice) loop
-
- -- Others choice, always matches
-
- if Nkind (Choice) = N_Others_Choice then
- exit Search;
-
- -- Range, check if value is in the range
-
- elsif Nkind (Choice) = N_Range then
- exit Search when
- Val >= Expr_Value (Low_Bound (Choice))
- and then
- Val <= Expr_Value (High_Bound (Choice));
-
- -- Choice is a subtype name. Note that we know it must
- -- be a static subtype, since otherwise it would have
- -- been diagnosed as illegal.
-
- elsif Is_Entity_Name (Choice)
- and then Is_Type (Entity (Choice))
- then
- exit Search when Is_In_Range (Expr, Etype (Choice));
-
- -- Choice is a subtype indication
-
- elsif Nkind (Choice) = N_Subtype_Indication then
- declare
- C : constant Node_Id := Constraint (Choice);
- R : constant Node_Id := Range_Expression (C);
-
- begin
- exit Search when
- Val >= Expr_Value (Low_Bound (R))
- and then
- Val <= Expr_Value (High_Bound (R));
- end;
-
- -- Choice is a simple expression
-
- else
- exit Search when Val = Expr_Value (Choice);
- end if;
-
- Next (Choice);
- end loop;
- end if;
-
- Next (Alt);
- pragma Assert (Present (Alt));
- end loop Search;
-
- -- The above loop *must* terminate by finding a match, since
- -- we know the case statement is valid, and the value of the
- -- expression is known at compile time. When we fall out of
- -- the loop, Alt points to the alternative that we know will
- -- be selected at run time.
-
- return Alt;
- end Find_Static_Alternative;
-
- ------------------
- -- First_Actual --
- ------------------
-
- function First_Actual (Node : Node_Id) return Node_Id is
- N : Node_Id;