Stmts := New_List;
- -- Create an explicit free statement to clean up the allocated
- -- object in case the accessibility check fails. Generate:
-
- -- Free (Obj_Ref);
-
- Free_Stmt := Make_Free_Statement (Loc, New_Copy (Obj_Ref));
- Set_Storage_Pool (Free_Stmt, Pool_Id);
-
- Append_To (Stmts, Free_Stmt);
-
- -- Finalize the object (if applicable), but wrap the call inside
- -- a block to ensure that the object would still be deallocated in
- -- case the finalization fails. Generate:
-
- -- begin
- -- [Deep_]Finalize (Obj_Ref.all);
- -- exception
- -- when others =>
- -- Free (Obj_Ref);
- -- raise;
- -- end;
-
- if Needs_Finalization (DesigT) then
- Prepend_To (Stmts,
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Final_Call (
- Obj_Ref =>
- Make_Explicit_Dereference (Loc,
- Prefix => New_Copy (Obj_Ref)),
- Typ => DesigT)),
-
- Exception_Handlers => New_List (
- Make_Exception_Handler (Loc,
- Exception_Choices => New_List (
- Make_Others_Choice (Loc)),
- Statements => New_List (
- New_Copy_Tree (Free_Stmt),
- Make_Raise_Statement (Loc)))))));
+ -- If the target does not support allocation/deallocation, simply
+ -- finalize the object (if applicable). Generate:
+
+ -- [Deep_]Finalize (Obj_Ref.all);
+
+ if Restriction_Active (No_Implicit_Heap_Allocations) then
+ if Needs_Finalization (DesigT) then
+ Append_To (Stmts,
+ Make_Final_Call (
+ Obj_Ref =>
+ Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)),
+ Typ => DesigT));
+ end if;
+
+ -- Finalize (if applicable) and deallocate the object in case the
+ -- accessibility check fails.
+
+ else
+ -- Create an explicit free statement to clean up the allocated
+ -- object in case the accessibility check fails. Generate:
+
+ -- Free (Obj_Ref);
+
+ Free_Stmt := Make_Free_Statement (Loc, New_Copy (Obj_Ref));
+ Set_Storage_Pool (Free_Stmt, Pool_Id);
+
+ Append_To (Stmts, Free_Stmt);
+
+ -- Finalize the object (if applicable), but wrap the call
+ -- inside a block to ensure that the object would still be
+ -- deallocated in case the finalization fails. Generate:
+
+ -- begin
+ -- [Deep_]Finalize (Obj_Ref.all);
+ -- exception
+ -- when others =>
+ -- Free (Obj_Ref);
+ -- raise;
+ -- end;
+
+ if Needs_Finalization (DesigT) then
+ Prepend_To (Stmts,
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Final_Call (
+ Obj_Ref =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Copy (Obj_Ref)),
+ Typ => DesigT)),
+
+ Exception_Handlers => New_List (
+ Make_Exception_Handler (Loc,
+ Exception_Choices => New_List (
+ Make_Others_Choice (Loc)),
+ Statements => New_List (
+ New_Copy_Tree (Free_Stmt),
+ Make_Raise_Statement (Loc)))))));
+ end if;
end if;
-- Signal the accessibility failure through a Program_Error
-- This procedure is called in the context of subprogram renaming, and
-- thus the attribute must be one that is a subprogram. All of those
- -- have at least one formal parameter, with the singular exception of
- -- AST_Entry (which is a real oddity, it is odd that this can be renamed
- -- at all!)
+ -- have at least one formal parameter, with the exceptions of AST_Entry
+ -- (which is a real oddity, it is odd that this can be renamed at all!)
+ -- and the GNAT attribute 'Img, which GNAT treats as renameable.
if not Is_Non_Empty_List (Parameter_Specifications (Spec)) then
- if Aname /= Name_AST_Entry then
+ if Aname /= Name_AST_Entry
+ and then Aname /= Name_Img
+ then
Error_Msg_N
("subprogram renaming an attribute must have formals", N);
return;
and then Etype (Nam) /= RTE (RE_AST_Handler)
then
declare
- P : constant Entity_Id := Prefix (Nam);
+ P : constant Node_Id := Prefix (Nam);
begin
- Find_Type (P);
+ -- The prefix of 'Img is an object that is evaluated for
+ -- each call of the function that renames it.
+
+ if Aname = Name_Img then
+ Preanalyze_And_Resolve (P);
+
+ -- For all other attribute renamings, the prefix is a subtype.
+
+ else
+ Find_Type (P);
+ end if;
if Is_Tagged_Type (Etype (P)) then
Ensure_Freeze_Node (Etype (P));