+2019-08-20 Bob Duff <duff@adacore.com>
+
+ * exp_ch6.adb (Needs_BIP_Alloc_Form): Call
+ Requires_Transient_Scope rather than checking constrainedness
+ and so forth. We have previously improved
+ Requires_Transient_Scope to return False in various cases,
+ notably a limited record with an access discriminant. This
+ change takes advantage of that to avoid using the secondary
+ stack for functions returning such types.
+ (Make_Build_In_Place_Call_In_Allocator): Be consistent by
+ calling Needs_BIP_Alloc_Form rather than Is_Constrained and so
+ forth.
+ * sem_ch4.adb (Analyze_Allocator): The above change causes the
+ compiler to generate code that is not legal Ada, in particular
+ an uninitialized allocator for indefinite subtype. This is
+ harmless, so we suppress the error message in this case.
+
2019-08-20 Gary Dismukes <dismukes@adacore.com>
* ali.adb, ali.ads, aspects.adb, checks.ads, checks.adb,
Set_Comes_From_Extended_Return_Statement (Return_Stmt);
Rewrite (N, Result);
- Analyze (N, Suppress => All_Checks);
+
+ declare
+ T : constant Entity_Id := Etype (Ret_Obj_Id);
+ begin
+ Analyze (N, Suppress => All_Checks);
+
+ -- In some cases, analysis of N can set the Etype of an N_Identifier
+ -- to a subtype of the Etype of the Entity of the N_Identifier, which
+ -- gigi doesn't like. Reset the Etypes correctly here.
+
+ if Nkind (Expression (Return_Stmt)) = N_Identifier
+ and then Entity (Expression (Return_Stmt)) = Ret_Obj_Id
+ then
+ Set_Etype (Ret_Obj_Id, T);
+ Set_Etype (Expression (Return_Stmt), T);
+ end if;
+ end;
end Expand_N_Extended_Return_Statement;
----------------------------
-- since it is already attached on the related finalization master.
-- Here and in related routines, we must examine the full view of the
- -- type, because the view at the point of call may differ from that
- -- that in the function body, and the expansion mechanism depends on
+ -- type, because the view at the point of call may differ from the
+ -- one in the function body, and the expansion mechanism depends on
-- the characteristics of the full view.
- if Is_Constrained (Underlying_Type (Result_Subt))
- and then not Needs_Finalization (Underlying_Type (Result_Subt))
- then
+ if Needs_BIP_Alloc_Form (Function_Id) then
+ Temp_Init := Empty;
+
+ -- Case of a user-defined storage pool. Pass an allocation parameter
+ -- indicating that the function should allocate its result in the
+ -- pool, and pass the pool. Use 'Unrestricted_Access because the
+ -- pool may not be aliased.
+
+ if Present (Associated_Storage_Pool (Acc_Type)) then
+ Alloc_Form := User_Storage_Pool;
+ Pool :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of
+ (Associated_Storage_Pool (Acc_Type), Loc),
+ Attribute_Name => Name_Unrestricted_Access);
+
+ -- No user-defined pool; pass an allocation parameter indicating that
+ -- the function should allocate its result on the heap.
+
+ else
+ Alloc_Form := Global_Heap;
+ Pool := Make_Null (No_Location);
+ end if;
+
+ -- The caller does not provide the return object in this case, so we
+ -- have to pass null for the object access actual.
+
+ Return_Obj_Actual := Empty;
+
+ else
-- Replace the initialized allocator of form "new T'(Func (...))"
-- with an uninitialized allocator of form "new T", where T is the
-- result subtype of the called function. The call to the function
-- perform the allocation of the return object, so we pass parameters
-- indicating that.
- else
- Temp_Init := Empty;
-
- -- Case of a user-defined storage pool. Pass an allocation parameter
- -- indicating that the function should allocate its result in the
- -- pool, and pass the pool. Use 'Unrestricted_Access because the
- -- pool may not be aliased.
-
- if Present (Associated_Storage_Pool (Acc_Type)) then
- Alloc_Form := User_Storage_Pool;
- Pool :=
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of
- (Associated_Storage_Pool (Acc_Type), Loc),
- Attribute_Name => Name_Unrestricted_Access);
-
- -- No user-defined pool; pass an allocation parameter indicating that
- -- the function should allocate its result on the heap.
-
- else
- Alloc_Form := Global_Heap;
- Pool := Make_Null (No_Location);
- end if;
-
- -- The caller does not provide the return object in this case, so we
- -- have to pass null for the object access actual.
-
- Return_Obj_Actual := Empty;
end if;
-- Declare the temp object
function Needs_BIP_Alloc_Form (Func_Id : Entity_Id) return Boolean is
pragma Assert (Is_Build_In_Place_Function (Func_Id));
Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
-
begin
- -- A build-in-place function needs to know which allocation form to
- -- use when:
- --
- -- 1) The result subtype is unconstrained. In this case, depending on
- -- the context of the call, the object may need to be created in the
- -- secondary stack, the heap, or a user-defined storage pool.
- --
- -- 2) The result subtype is tagged. In this case the function call may
- -- dispatch on result and thus needs to be treated in the same way as
- -- calls to functions with class-wide results, because a callee that
- -- can be dispatched to may have any of various result subtypes, so
- -- if any of the possible callees would require an allocation form to
- -- be passed then they all do.
- --
- -- 3) The result subtype needs finalization actions. In this case, based
- -- on the context of the call, the object may need to be created at
- -- the caller site, in the heap, or in a user-defined storage pool.
-
- return
- not Is_Constrained (Func_Typ)
- or else Is_Tagged_Type (Func_Typ)
- or else Needs_Finalization (Func_Typ);
+ return Requires_Transient_Scope (Func_Typ);
end Needs_BIP_Alloc_Form;
--------------------------------------
("\constraint with discriminant values required", N);
end if;
- -- Limited Ada 2005 and general nonlimited case
+ -- Limited Ada 2005 and general nonlimited case.
+ -- This is an error, except in the case of an
+ -- uninitialized allocator that is generated
+ -- for a build-in-place function return of a
+ -- discriminated but compile-time-known-size
+ -- type.
else
- Error_Msg_N
- ("uninitialized unconstrained allocation not "
- & "allowed", N);
+ if Original_Node (N) /= N
+ and then Nkind (Original_Node (N)) = N_Allocator
+ then
+ declare
+ Qual : constant Node_Id :=
+ Expression (Original_Node (N));
+ pragma Assert
+ (Nkind (Qual) = N_Qualified_Expression);
+ Call : constant Node_Id := Expression (Qual);
+ pragma Assert
+ (Is_Expanded_Build_In_Place_Call (Call));
+ begin
+ null;
+ end;
- if Is_Array_Type (Type_Id) then
+ else
Error_Msg_N
- ("\qualified expression or constraint with "
- & "array bounds required", N);
+ ("uninitialized unconstrained allocation not "
+ & "allowed", N);
- elsif Has_Unknown_Discriminants (Type_Id) then
- Error_Msg_N ("\qualified expression required", N);
+ if Is_Array_Type (Type_Id) then
+ Error_Msg_N
+ ("\qualified expression or constraint with "
+ & "array bounds required", N);
- else pragma Assert (Has_Discriminants (Type_Id));
- Error_Msg_N
- ("\qualified expression or constraint with "
- & "discriminant values required", N);
+ elsif Has_Unknown_Discriminants (Type_Id) then
+ Error_Msg_N ("\qualified expression required", N);
+
+ else pragma Assert (Has_Discriminants (Type_Id));
+ Error_Msg_N
+ ("\qualified expression or constraint with "
+ & "discriminant values required", N);
+ end if;
end if;
end if;
end if;
projects / thirdparty / gcc.git / commitdiff
