-- the designated type. Otherwise freezing the access type does not freeze
-- the designated type.
+ function Should_Freeze_Type (Typ : Entity_Id; E : Entity_Id) return Boolean;
+ -- If Typ is in the current scope or in an instantiation, then return True.
+ -- ???Expression functions (represented by E) shouldn't freeze types in
+ -- general, but our current expansion and freezing model requires an early
+ -- freezing when the dispatch table is needed or when building an aggregate
+ -- with a subtype of Typ, so return True also in this case.
+ -- Note that expression function completions do freeze and are
+ -- handled in Sem_Ch6.Analyze_Expression_Function.
+
+ ------------------------
+ -- Should_Freeze_Type --
+ ------------------------
+
+ function Should_Freeze_Type
+ (Typ : Entity_Id; E : Entity_Id) return Boolean
+ is
+ function Is_Dispatching_Call_Or_Aggregate
+ (N : Node_Id) return Traverse_Result;
+ -- Return Abandon if N is a dispatching call to a subprogram
+ -- declared in the same scope as Typ or an aggregate whose type
+ -- is Typ.
+
+ --------------------------------------
+ -- Is_Dispatching_Call_Or_Aggregate --
+ --------------------------------------
+
+ function Is_Dispatching_Call_Or_Aggregate
+ (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Function_Call
+ and then Present (Controlling_Argument (N))
+ and then Scope (Entity (Original_Node (Name (N))))
+ = Scope (Typ)
+ then
+ return Abandon;
+ elsif Nkind (N) = N_Aggregate
+ and then Base_Type (Etype (N)) = Base_Type (Typ)
+ then
+ return Abandon;
+ else
+ return OK;
+ end if;
+ end Is_Dispatching_Call_Or_Aggregate;
+
+ -------------------------
+ -- Need_Dispatch_Table --
+ -------------------------
+
+ function Need_Dispatch_Table is new
+ Traverse_Func (Is_Dispatching_Call_Or_Aggregate);
+ -- Return Abandon if the input expression requires access to
+ -- Typ's dispatch table.
+
+ Decl : constant Node_Id :=
+ (if No (E) then E else Original_Node (Unit_Declaration_Node (E)));
+
+ -- Start of processing for Should_Freeze_Type
+
+ begin
+ return Within_Scope (Typ, Current_Scope)
+ or else In_Instance
+ or else (Present (Decl)
+ and then Nkind (Decl) = N_Expression_Function
+ and then Need_Dispatch_Table (Expression (Decl)) = Abandon);
+ end Should_Freeze_Type;
+
procedure Process_Default_Expressions
(E : Entity_Id;
After : in out Node_Id);
Set_Etype (Formal, F_Type);
end if;
- if not From_Limited_With (F_Type) then
+ if not From_Limited_With (F_Type)
+ and then Should_Freeze_Type (F_Type, E)
+ then
Freeze_And_Append (F_Type, N, Result);
end if;
Set_Etype (E, R_Type);
end if;
- Freeze_And_Append (R_Type, N, Result);
+ if Should_Freeze_Type (R_Type, E) then
+ Freeze_And_Append (R_Type, N, Result);
+ end if;
-- Check suspicious return type for C function
-- Here for other than a subprogram or type
else
- -- If entity has a type, and it is not a generic unit, then freeze
- -- it first (RM 13.14(10)).
+ -- If entity has a type declared in the current scope, and it is
+ -- not a generic unit, then freeze it first.
if Present (Etype (E))
and then Ekind (E) /= E_Generic_Function
+ and then Within_Scope (Etype (E), Current_Scope)
then
Freeze_And_Append (Etype (E), N, Result);
-- tree. This is an unusual case, but there are some legitimate
-- situations in which this occurs, notably when the expressions
-- in the range of a type declaration are resolved. We simply
- -- ignore the freeze request in this case. Is this right ???
+ -- ignore the freeze request in this case.
if No (Parent_P) then
return;
end case;
-- We fall through the case if we did not yet find the proper
- -- place in the free for inserting the freeze node, so climb.
+ -- place in the tree for inserting the freeze node, so climb.
P := Parent_P;
end loop;