+ --------------------------------
+ -- Build_Classwide_Expression --
+ --------------------------------
+
+ procedure Build_Classwide_Expression (Prag : Node_Id; Subp : Entity_Id) is
+ function Replace_Entity (N : Node_Id) return Traverse_Result;
+ -- Replace reference to formal of inherited operation or to primitive
+ -- operation of root type, with corresponding entity for derived type,
+ -- when constructing the classwide condition of an overridding
+ -- subprogram.
+
+ --------------------
+ -- Replace_Entity --
+ --------------------
+
+ function Replace_Entity (N : Node_Id) return Traverse_Result is
+ New_E : Entity_Id;
+
+ begin
+ if Nkind (N) = N_Identifier
+ and then Present (Entity (N))
+ and then
+ (Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N)))
+ and then
+ (Nkind (Parent (N)) /= N_Attribute_Reference
+ or else Attribute_Name (Parent (N)) /= Name_Class)
+ then
+ -- The replacement does not apply to dispatching calls within the
+ -- condition, but only to calls whose static tag is that of the
+ -- parent type.
+
+ if Is_Subprogram (Entity (N))
+ and then Nkind (Parent (N)) = N_Function_Call
+ and then Present (Controlling_Argument (Parent (N)))
+ then
+ return OK;
+ end if;
+
+ -- Determine whether entity has a renaming
+
+ New_E := Primitives_Mapping.Get (Entity (N));
+
+ if Present (New_E) then
+ Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
+ end if;
+
+ -- Check that there are no calls left to abstract operations if
+ -- the current subprogram is not abstract.
+
+ if Nkind (Parent (N)) = N_Function_Call
+ and then N = Name (Parent (N))
+ then
+ if not Is_Abstract_Subprogram (Subp)
+ and then Is_Abstract_Subprogram (Entity (N))
+ then
+ Error_Msg_Sloc := Sloc (Current_Scope);
+ Error_Msg_NE
+ ("cannot call abstract subprogram in inherited condition "
+ & "for&#", N, Current_Scope);
+
+ elsif SPARK_Mode = On
+ and then Warn_On_Suspicious_Contract
+ and then Present (Alias (Subp))
+ then
+ Error_Msg_NE
+ ("?inherited condition is modified, build a wrapper "
+ & "for&", Parent (Subp), Subp);
+ end if;
+ end if;
+
+ -- Update type of function call node, which should be the same as
+ -- the function's return type.
+
+ if Is_Subprogram (Entity (N))
+ and then Nkind (Parent (N)) = N_Function_Call
+ then
+ Set_Etype (Parent (N), Etype (Entity (N)));
+ end if;
+
+ -- The whole expression will be reanalyzed
+
+ elsif Nkind (N) in N_Has_Etype then
+ Set_Analyzed (N, False);
+ end if;
+
+ return OK;
+ end Replace_Entity;
+
+ procedure Replace_Condition_Entities is
+ new Traverse_Proc (Replace_Entity);
+
+ -- Start of processing for Build_Classwide_Expression
+
+ begin
+ Replace_Condition_Entities (Prag);
+ end Build_Classwide_Expression;
+