+2017-10-09 Bob Duff <duff@adacore.com>
+
+ * exp_ch6.adb (Expand_N_Extended_Return_Statement): Add self-checking
+ code so if BIPAlloc is not passed in, it will likely raise
+ Program_Error instead of cause miscellaneous chaos.
+ (Is_Build_In_Place_Result_Type): Return False if not Expander_Active,
+ as for the other Is_B-I-P... functions.
+ * sem_aggr.adb (Resolve_Extension_Aggregate): For an extension
+ aggregate whose ancestor part is a build-in-place call returning a
+ nonlimited type, transform the assignment to the ancestor part to use a
+ temp.
+ * sem_ch3.adb (Build_Itype_Reference): Handle the case where we're
+ creating an Itype for a library unit entity.
+ (Check_Initialization): Avoid spurious error message on
+ internally-generated call.
+ * sem_ch5.adb (Analyze_Assignment): Handle the case where the
+ right-hand side is a build-in-place call. This didn't happen when b-i-p
+ was only for limited types.
+ * sem_ch6.adb (Create_Extra_Formals): Remove assumption that b-i-p
+ implies >= Ada 2005.
+ * sem_ch7.adb (Scan_Subprogram_Refs): Avoid traversing the same nodes
+ repeatedly.
+ * sem_util.adb (Next_Actual): Handle case of build-in-place call.
+
+2017-10-09 Arnaud Charlet <charlet@adacore.com>
+
+ * doc/gnat_ugn/gnat_and_program_execution.rst: Minor edit.
+
+2017-10-09 Piotr Trojanek <trojanek@adacore.com>
+
+ * libgnarl/s-taprob.adb: Minor whitespace fix.
+
+2017-10-09 Bob Duff <duff@adacore.com>
+
+ * namet.ads: Minor comment fix.
+
+2017-10-09 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_aux.adb (Unit_Declaration_Node): Detect protected declarations,
+ just like other program units listed in Ada RM 10.1(1).
+
+2017-10-09 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch8.adb (Update_Chain_In_Scope): Modify warning messages.
+
+2017-10-09 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Analyze_Associations, Check_Generic_Parent): If an
+ actual for a formal package is an instantiation of a child unit, create
+ a freeze node for the instance of the parent if it appears in the same
+ scope and is not frozen yet.
+
+2017-10-09 Pierre-Marie de Rodat <derodat@adacore.com>
+
+ * exp_atag.ads, libgnat/a-tags.adb, libgnat/a-tags.ads: Enhance
+ in-source documentation for tagged types's Offset_To_Top.
+
+2017-10-09 Bob Duff <duff@adacore.com>
+
+ * exp_ch3.adb (Build_Assignment): Parameter name N was somewhat
+ confusing. Same for N_Loc. Remove assumption that b-i-p implies
+ limited. This is for the case of a function call that occurs as the
+ default for a record component.
+ (Expand_N_Object_Declaration): Deal with the case where expansion has
+ created an object declaration initialized with something like
+ F(...)'Reference.
+ * exp_ch3.adb: Minor reformatting.
+
+2017-10-09 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_attr.adb (Expand_Attribute_Reference, case 'Valid): The prefix of
+ the attribute is an object, but it may appear within a conversion. The
+ object itself must be retrieved when generating the range test that
+ implements the validity check on a scalar type.
+
2017-10-05 Eric Botcazou <ebotcazou@adacore.com>
PR ada/82393
``gnatmem`` makes use of the output created by the special version of
allocation and deallocation routines that record call information. This allows
it to obtain accurate dynamic memory usage history at a minimal cost to the
- execution speed. Note however, that ``gnatmem`` is not supported on all
- platforms (currently, it is supported on AIX, HP-UX, GNU/Linux, Solaris and
- Windows).
+ execution speed. Note however, that ``gnatmem`` is only supported on
+ GNU/Linux and Windows.
The ``gnatmem`` command has the form
-- --
-- S p e c --
-- --
--- Copyright (C) 2006-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
--
-- Generates:
-- Offset_To_Top_Ptr
- -- (Address!(Tag_Ptr!(This).all) - Offset_To_Top_Offset)
+ -- (Address!(Tag_Ptr!(This).all) - Offset_To_Top_Offset).all
function Build_Set_Predefined_Prim_Op_Address
(Loc : Source_Ptr;
begin
-- The prefix of attribute 'Valid should always denote an object
-- reference. The reference is either coming directly from source
- -- or is produced by validity check expansion.
+ -- or is produced by validity check expansion. The object may be
+ -- wrapped in a conversion in which case the call to Unqual_Conv
+ -- will yield it.
-- If the prefix denotes a variable which captures the value of
-- an object for validation purposes, use the variable in the
-- if not Temp in ... then
if Is_Validation_Variable_Reference (Pref) then
- Temp := New_Occurrence_Of (Entity (Pref), Loc);
+ Temp := New_Occurrence_Of (Entity (Unqual_Conv (Pref)), Loc);
-- Otherwise the prefix is either a source object or a constant
-- produced by validity check expansion. Generate:
Rec_Type : Entity_Id;
Set_Tag : Entity_Id := Empty;
- function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id;
- -- Build an assignment statement which assigns the default expression
- -- to its corresponding record component if defined. The left hand side
- -- of the assignment is marked Assignment_OK so that initialization of
+ function Build_Assignment
+ (Id : Entity_Id; Default : Node_Id) return List_Id;
+ -- Build an assignment statement that assigns the default expression to
+ -- its corresponding record component if defined. The left-hand side of
+ -- the assignment is marked Assignment_OK so that initialization of
-- limited private records works correctly. This routine may also build
-- an adjustment call if the component is controlled.
-- Build_Assignment --
----------------------
- function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is
- N_Loc : constant Source_Ptr := Sloc (N);
+ function Build_Assignment
+ (Id : Entity_Id; Default : Node_Id) return List_Id
+ is
+ Default_Loc : constant Source_Ptr := Sloc (Default);
Typ : constant Entity_Id := Underlying_Type (Etype (Id));
Adj_Call : Node_Id;
- Exp : Node_Id := N;
- Kind : Node_Kind := Nkind (N);
+ Exp : Node_Id := Default;
+ Kind : Node_Kind := Nkind (Default);
Lhs : Node_Id;
Res : List_Id;
and then Present (Discriminal_Link (Entity (N)))
then
Val :=
- Make_Selected_Component (N_Loc,
+ Make_Selected_Component (Default_Loc,
Prefix => New_Copy_Tree (Lhs),
Selector_Name =>
- New_Occurrence_Of (Discriminal_Link (Entity (N)), N_Loc));
+ New_Occurrence_Of
+ (Discriminal_Link (Entity (N)), Default_Loc));
if Present (Val) then
Rewrite (N, New_Copy_Tree (Val));
begin
Lhs :=
- Make_Selected_Component (N_Loc,
+ Make_Selected_Component (Default_Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
- Selector_Name => New_Occurrence_Of (Id, N_Loc));
+ Selector_Name => New_Occurrence_Of (Id, Default_Loc));
Set_Assignment_OK (Lhs);
if Nkind (Exp) = N_Aggregate
-- traversing the expression. ???
if Kind = N_Attribute_Reference
- and then Nam_In (Attribute_Name (N), Name_Unchecked_Access,
+ and then Nam_In (Attribute_Name (Default), Name_Unchecked_Access,
Name_Unrestricted_Access)
- and then Is_Entity_Name (Prefix (N))
- and then Is_Type (Entity (Prefix (N)))
- and then Entity (Prefix (N)) = Rec_Type
+ and then Is_Entity_Name (Prefix (Default))
+ and then Is_Type (Entity (Prefix (Default)))
+ and then Entity (Prefix (Default)) = Rec_Type
then
Exp :=
- Make_Attribute_Reference (N_Loc,
+ Make_Attribute_Reference (Default_Loc,
Prefix =>
- Make_Identifier (N_Loc, Name_uInit),
+ Make_Identifier (Default_Loc, Name_uInit),
Attribute_Name => Name_Unrestricted_Access);
end if;
if Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then
Append_To (Res,
- Make_Assignment_Statement (N_Loc,
+ Make_Assignment_Statement (Default_Loc,
Name =>
- Make_Selected_Component (N_Loc,
+ Make_Selected_Component (Default_Loc,
Prefix =>
New_Copy_Tree (Lhs, New_Scope => Proc_Id),
Selector_Name =>
- New_Occurrence_Of (First_Tag_Component (Typ), N_Loc)),
+ New_Occurrence_Of
+ (First_Tag_Component (Typ), Default_Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
(Node
(First_Elmt
(Access_Disp_Table (Underlying_Type (Typ)))),
- N_Loc))));
+ Default_Loc))));
end if;
-- Adjust the component if controlled except if it is an aggregate
-- that will be expanded inline.
if Kind = N_Qualified_Expression then
- Kind := Nkind (Expression (N));
+ Kind := Nkind (Expression (Default));
end if;
if Needs_Finalization (Typ)
and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate))
- and then not Is_Limited_View (Typ)
+ and then not Is_Build_In_Place_Function_Call (Exp)
then
Adj_Call :=
Make_Adjust_Call
return;
+ -- This is the same as the previous 'elsif', except that the call has
+ -- been transformed by other expansion activities into something like
+ -- F(...)'Reference.
+
+ elsif Nkind (Expr_Q) = N_Reference
+ and then Is_Build_In_Place_Function_Call (Prefix (Expr_Q))
+ and then not Is_Expanded_Build_In_Place_Call
+ (Unqual_Conv (Prefix (Expr_Q)))
+ then
+ Make_Build_In_Place_Call_In_Anonymous_Context (Prefix (Expr_Q));
+
+ -- The previous call expands the expression initializing the
+ -- built-in-place object into further code that will be analyzed
+ -- later. No further expansion needed here.
+
+ return;
+
-- Ada 2005 (AI-318-02): Specialization of the previous case for
-- expressions containing a build-in-place function call whose
-- returned object covers interface types, and Expr_Q has calls to
Temp_Typ => Ref_Type,
Func_Id => Func_Id,
Ret_Typ => Ret_Obj_Typ,
- Alloc_Expr => Heap_Allocator)))),
+ Alloc_Expr => Heap_Allocator))),
+
+ -- ???If all is well, we can put the following
+ -- 'elsif' in the 'else', but this is a useful
+ -- self-check in case caller and callee don't agree
+ -- on whether BIPAlloc and so on should be passed.
+
+ Make_Elsif_Part (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Occurrence_Of (Obj_Alloc_Formal, Loc),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ UI_From_Int (BIP_Allocation_Form'Pos
+ (User_Storage_Pool)))),
+
+ Then_Statements => New_List (
+ Pool_Decl,
+ Build_Heap_Allocator
+ (Temp_Id => Alloc_Obj_Id,
+ Temp_Typ => Ref_Type,
+ Func_Id => Func_Id,
+ Ret_Typ => Ret_Obj_Typ,
+ Alloc_Expr => Pool_Allocator)))),
+
+ -- Raise Program_Error if it's none of the above;
+ -- this is a compiler bug. ???PE_All_Guards_Closed
+ -- is bogus; we should have a new code.
Else_Statements => New_List (
- Pool_Decl,
- Build_Heap_Allocator
- (Temp_Id => Alloc_Obj_Id,
- Temp_Typ => Ref_Type,
- Func_Id => Func_Id,
- Ret_Typ => Ret_Obj_Typ,
- Alloc_Expr => Pool_Allocator)));
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_All_Guards_Closed)));
-- If a separate initialization assignment was created
-- earlier, append that following the assignment of the
function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean is
begin
+ if not Expander_Active then
+ return False;
+ end if;
+
-- In Ada 2005 all functions with an inherently limited return type
-- must be handled using a build-in-place profile, including the case
-- of a function with a limited interface result, where the function
begin
if Init_Priority = Unspecified_Priority then
- Init_Priority := System.Priority'Last;
+ Init_Priority := System.Priority'Last;
end if;
Initialize_Lock (Init_Priority, Object.L'Access);
begin
Curr_DT := DT (To_Tag_Ptr (This).all);
+ -- See the documentation of Dispatch_Table_Wrapper.Offset_To_Top
+
if Curr_DT.Offset_To_Top = SSE.Storage_Offset'Last then
+
+ -- The parent record type has variable-size components, so the
+ -- instance-specific offset is stored in the tagged record, right
+ -- after the reference to Curr_DT (which is a secondary dispatch
+ -- table).
+
return To_Storage_Offset_Ptr (This + Tag_Size).all;
+
else
+ -- The offset is compile-time known, so it is simply stored in the
+ -- Offset_To_Top field.
+
return Curr_DT.Offset_To_Top;
end if;
end Offset_To_Top;
-- Prims_Ptr table.
Offset_To_Top : SSE.Storage_Offset;
- TSD : System.Address;
+ -- Offset between the _Tag field and the field that contains the
+ -- reference to this dispatch table. For primary dispatch tables it is
+ -- zero. For secondary dispatch tables: if the parent record type (if
+ -- any) has a compile-time-known size, then Offset_To_Top contains the
+ -- expected value, otherwise it contains SSE.Storage_Offset'Last and the
+ -- actual offset is to be found in the tagged record, right after the
+ -- field that contains the reference to this dispatch table. See the
+ -- implementation of Ada.Tags.Offset_To_Top for the corresponding logic.
+
+ TSD : System.Address;
Prims_Ptr : aliased Address_Array (1 .. Num_Prims);
-- The size of the Prims_Ptr array actually depends on the tagged type
-- to which it applies. For each tagged type, the expander computes the
- -- actual array size, allocates the Dispatch_Table record accordingly.
+ -- actual array size, allocating the Dispatch_Table record accordingly.
end record;
type Dispatch_Table_Ptr is access all Dispatch_Table_Wrapper;
-- Sets the Int value associated with the given name
function Is_Internal_Name (Id : Name_Id) return Boolean;
- -- Returns True if the name is an internal name (i.e. contains a character
+ -- Returns True if the name is an internal name, i.e. contains a character
-- for which Is_OK_Internal_Letter is true, or if the name starts or ends
-- with an underscore.
--
with Elists; use Elists;
with Errout; use Errout;
with Expander; use Expander;
+with Exp_Ch6; use Exp_Ch6;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
-- Verify that the type of the ancestor part is a non-private ancestor
-- of the expected type, which must be a type extension.
+ procedure Transform_BIP_Assignment (Typ : Entity_Id);
+ -- For an extension aggregate whose ancestor part is a build-in-place
+ -- call returning a nonlimited type, this is used to transform the
+ -- assignment to the ancestor part to use a temp.
+
----------------------------
-- Valid_Limited_Ancestor --
----------------------------
return False;
end Valid_Ancestor_Type;
+ procedure Transform_BIP_Assignment (Typ : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', A);
+ Obj_Decl : constant Node_Id :=
+ Make_Object_Declaration
+ (Loc,
+ Defining_Identifier => Def_Id,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
+ Expression => A,
+ Has_Init_Expression => True);
+ begin
+ Set_Etype (Def_Id, Typ);
+ Set_Ancestor_Part (N, New_Occurrence_Of (Def_Id, Loc));
+ Insert_Action (N, Obj_Decl);
+ end Transform_BIP_Assignment;
+
-- Start of processing for Resolve_Extension_Aggregate
begin
Get_First_Interp (A, I, It);
while Present (It.Typ) loop
- -- Only consider limited interpretations in the Ada 2005 case
+ -- Consider limited interpretations if Ada 2005 or higher
if Is_Tagged_Type (It.Typ)
and then (Ada_Version >= Ada_2005
Error_Msg_N ("ancestor part must be statically tagged", A);
else
+ -- We are using the build-in-place protocol, but we can't build
+ -- in place, because we need to call the function before
+ -- allocating the aggregate. Could do better for null
+ -- extensions, and maybe for nondiscriminated types.
+ -- This is wrong for limited, but those were wrong already.
+
+ if not Is_Limited_View (A_Type)
+ and then Is_Build_In_Place_Function_Call (A)
+ then
+ Transform_BIP_Assignment (A_Type);
+ end if;
+
Resolve_Record_Aggregate (N, Typ);
end if;
end if;
and then Nkind (N) /= N_Package_Renaming_Declaration
and then Nkind (N) /= N_Procedure_Instantiation
and then Nkind (N) /= N_Protected_Body
+ and then Nkind (N) /= N_Protected_Type_Declaration
and then Nkind (N) /= N_Subprogram_Declaration
and then Nkind (N) /= N_Subprogram_Body
and then Nkind (N) /= N_Subprogram_Body_Stub
-- body.
Explicit_Freeze_Check : declare
- Actual : constant Entity_Id := Entity (Match);
+ Actual : constant Entity_Id := Entity (Match);
+ Gen_Par : Entity_Id;
Needs_Freezing : Boolean;
S : Entity_Id;
-- The actual may be an instantiation of a unit
-- declared in a previous instantiation. If that
-- one is also in the current compilation, it must
- -- itself be frozen before the actual.
+ -- itself be frozen before the actual. The actual
+ -- may be an instantiation of a generic child unit,
+ -- in which case the same applies to the instance
+ -- of the parent which must be frozen before the
+ -- actual.
-- Should this itself be recursive ???
--------------------------
--------------------------
procedure Check_Generic_Parent is
- Par : Entity_Id;
+ Inst : constant Node_Id :=
+ Next (Unit_Declaration_Node (Actual));
+ Par : Entity_Id;
begin
- if Nkind (Parent (Actual)) =
- N_Package_Specification
+ Par := Empty;
+
+ if Nkind (Parent (Actual)) = N_Package_Specification
then
Par := Scope (Generic_Parent (Parent (Actual)));
-
- if Is_Generic_Instance (Par)
- and then Scope (Par) = Current_Scope
- and then
- (No (Freeze_Node (Par))
- or else
- not Is_List_Member (Freeze_Node (Par)))
+ if Is_Generic_Instance (Par) then
+ null;
+
+ -- If the actual is a child generic unit, check
+ -- whether the instantiation of the parent is
+ -- also local and must also be frozen now.
+ -- We must retrieve the instance node to locate
+ -- the parent instance if any.
+
+ elsif Ekind (Par) = E_Generic_Package
+ and then Is_Child_Unit (Gen_Par)
+ and then Ekind (Scope (Gen_Par))
+ = E_Generic_Package
then
- Set_Has_Delayed_Freeze (Par);
- Append_Elmt (Par, Actuals_To_Freeze);
+ if Nkind (Inst) = N_Package_Instantiation
+ and then
+ Nkind (Name (Inst)) = N_Expanded_Name
+ then
+
+ -- Retrieve entity of psarent instance.
+
+ Par := Entity (Prefix (Name (Inst)));
+ end if;
+
+ else
+ Par := Empty;
end if;
end if;
+
+ if Present (Par)
+ and then Is_Generic_Instance (Par)
+ and then Scope (Par) = Current_Scope
+ and then
+ (No (Freeze_Node (Par))
+ or else
+ not Is_List_Member (Freeze_Node (Par)))
+ then
+ Set_Has_Delayed_Freeze (Par);
+ Append_Elmt (Par, Actuals_To_Freeze);
+ end if;
end Check_Generic_Parent;
-- Start of processing for Explicit_Freeze_Check
begin
+ if Present (Renamed_Entity (Actual)) then
+ Gen_Par :=
+ Generic_Parent (Specification (
+ Unit_Declaration_Node (
+ Renamed_Entity (Actual))));
+ else
+ Gen_Par := Generic_Parent
+ (Specification (Unit_Declaration_Node (Actual)));
+ end if;
+
if not Expander_Active
or else not Has_Completion (Actual)
or else not In_Same_Source_Unit (I_Node, Actual)
return;
else
Set_Itype (IR, Ityp);
- Insert_After (Nod, IR);
+
+ -- If Nod is a library unit entity, then Insert_After won't work,
+ -- because Nod is not a member of any list. Therefore, we use
+ -- Add_Global_Declaration in this case. This can happen if we have a
+ -- build-in-place library function.
+
+ if (Nkind (Nod) in N_Entity
+ and then Is_Compilation_Unit (Nod))
+ or else
+ (Nkind (Nod) = N_Defining_Program_Unit_Name
+ and then Is_Compilation_Unit (Defining_Identifier (Nod)))
+ then
+ Add_Global_Declaration (IR);
+ else
+ Insert_After (Nod, IR);
+ end if;
end if;
end Build_Itype_Reference;
if Nkind (Exp) = N_Type_Conversion
and then Nkind (Expression (Exp)) = N_Function_Call
then
- Error_Msg_N
- ("illegal context for call"
- & " to function with limited result", Exp);
+ -- No error for internally-generated object declarations,
+ -- which can come from build-in-place assignment statements.
+
+ if Nkind (Parent (Exp)) = N_Object_Declaration
+ and then not Comes_From_Source
+ (Defining_Identifier (Parent (Exp)))
+ then
+ null;
+
+ else
+ Error_Msg_N
+ ("illegal context for call"
+ & " to function with limited result", Exp);
+ end if;
else
Error_Msg_N
procedure Analyze_Assignment (N : Node_Id) is
Lhs : constant Node_Id := Name (N);
- Rhs : constant Node_Id := Expression (N);
-
- Decl : Node_Id;
- T1 : Entity_Id;
- T2 : Entity_Id;
-
- Save_Full_Analysis : Boolean := False; -- initialize to prevent warning
+ Rhs : Node_Id := Expression (N);
procedure Diagnose_Non_Variable_Lhs (N : Node_Id);
-- N is the node for the left hand side of an assignment, and it is not
-- nominal subtype. This procedure is used to deal with cases where the
-- nominal subtype must be replaced by the actual subtype.
+ procedure Transform_BIP_Assignment (Typ : Entity_Id);
+ function Should_Transform_BIP_Assignment
+ (Typ : Entity_Id) return Boolean;
+ -- If the right-hand side of an assignment statement is a build-in-place
+ -- call we cannot build in place, so we insert a temp initialized with
+ -- the call, and transform the assignment statement to copy the temp.
+ -- Transform_BIP_Assignment does the tranformation, and
+ -- Should_Transform_BIP_Assignment determines whether we should.
+ -- The same goes for qualified expressions and conversions whose
+ -- operand is such a call.
+ --
+ -- This is only for nonlimited types; assignment statements are illegal
+ -- for limited types, but are generated internally for aggregates and
+ -- init procs. These limited-type are not really assignment statements
+ -- -- conceptually, they are initializations, so should not be
+ -- transformed.
+ --
+ -- Similarly, for nonlimited types, aggregates and init procs generate
+ -- assignment statements that are really initializations. These are
+ -- marked No_Ctrl_Actions.
+
+ function Should_Transform_BIP_Assignment
+ (Typ : Entity_Id) return Boolean
+ is
+ Result : Boolean;
+ begin
+ if Expander_Active
+ and then not Is_Limited_View (Typ)
+ and then Is_Build_In_Place_Result_Type (Typ)
+ and then not No_Ctrl_Actions (N)
+ then
+ -- This function is called early, before name resolution is
+ -- complete, so we have to deal with things that might turn into
+ -- function calls later. N_Function_Call and N_Op nodes are the
+ -- obvious case. An N_Identifier or N_Expanded_Name is a
+ -- parameterless function call if it denotes a function.
+ -- Finally, an attribute reference can be a function call.
+
+ case Nkind (Unqual_Conv (Rhs)) is
+ when N_Function_Call | N_Op =>
+ Result := True;
+ when N_Identifier | N_Expanded_Name =>
+ case Ekind (Entity (Unqual_Conv (Rhs))) is
+ when E_Function | E_Operator =>
+ Result := True;
+ when others =>
+ Result := False;
+ end case;
+ when N_Attribute_Reference =>
+ Result := Attribute_Name (Unqual_Conv (Rhs)) = Name_Input;
+ -- T'Input will turn into a call whose result type is T
+ when others =>
+ Result := False;
+ end case;
+ else
+ Result := False;
+ end if;
+ return Result;
+ end Should_Transform_BIP_Assignment;
+
+ procedure Transform_BIP_Assignment (Typ : Entity_Id) is
+ -- Tranform "X : [constant] T := F (...);" into:
+ --
+ -- Temp : constant T := F (...);
+ -- X := Temp;
+
+ Loc : constant Source_Ptr := Sloc (N);
+ Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', Rhs);
+ Obj_Decl : constant Node_Id :=
+ Make_Object_Declaration
+ (Loc,
+ Defining_Identifier => Def_Id,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
+ Expression => Rhs,
+ Has_Init_Expression => True);
+ begin
+ Set_Etype (Def_Id, Typ);
+ Set_Expression (N, New_Occurrence_Of (Def_Id, Loc));
+
+ -- At this point, Rhs is no longer equal to Expression (N), so:
+
+ Rhs := Expression (N);
+
+ Insert_Action (N, Obj_Decl);
+ end Transform_BIP_Assignment;
+
-------------------------------
-- Diagnose_Non_Variable_Lhs --
-------------------------------
(Opnd : Node_Id;
Opnd_Type : in out Entity_Id)
is
+ Decl : Node_Id;
begin
Require_Entity (Opnd);
-- Local variables
+ T1 : Entity_Id;
+ T2 : Entity_Id;
+
+ Save_Full_Analysis : Boolean;
+
Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
-- Save the Ghost mode to restore on exit
null;
elsif Has_Compatible_Type (Rhs, It.Typ) then
- if T1 /= Any_Type then
-
+ if T1 = Any_Type then
+ T1 := It.Typ;
+ else
-- An explicit dereference is overloaded if the prefix
-- is. Try to remove the ambiguity on the prefix, the
-- error will be posted there if the ambiguity is real.
("ambiguous left-hand side in assignment", Lhs);
exit;
end if;
- else
- T1 := It.Typ;
end if;
end if;
end if;
end if;
+ -- Deal with build-in-place calls for nonlimited types.
+ -- We don't do this later, because resolving the rhs
+ -- tranforms it incorrectly for build-in-place.
+
+ if Should_Transform_BIP_Assignment (Typ => T1) then
+ Transform_BIP_Assignment (Typ => T1);
+ end if;
+ pragma Assert (not Should_Transform_BIP_Assignment (Typ => T1));
+
-- The resulting assignment type is T1, so now we will resolve the left
-- hand side of the assignment using this determined type.
Expander_Mode_Restore;
Full_Analysis := Save_Full_Analysis;
end if;
+
+ pragma Assert (not Should_Transform_BIP_Assignment (Typ => T1));
end Analyze_Assignment;
-----------------------------
-- Ada 2005 (AI-318-02): In the case of build-in-place functions, add
-- appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind.
- if Ada_Version >= Ada_2005 and then Is_Build_In_Place_Function (E) then
+ if Is_Build_In_Place_Function (E) then
declare
Result_Subt : constant Entity_Id := Etype (E);
Full_Subt : constant Entity_Id := Available_View (Result_Subt);
subtype Entity_Header_Num is Integer range 0 .. Entity_Table_Size - 1;
-- Range of headers in hash table
- function Entity_Hash (Id : Entity_Id) return Entity_Header_Num;
+ function Node_Hash (Id : Entity_Id) return Entity_Header_Num;
-- Simple hash function for Entity_Ids
package Subprogram_Table is new GNAT.Htable.Simple_HTable
Element => Boolean,
No_Element => False,
Key => Entity_Id,
- Hash => Entity_Hash,
+ Hash => Node_Hash,
Equal => "=");
-- Hash table to record which subprograms are referenced. It is declared
-- at library level to avoid elaborating it for every call to Analyze.
+ package Traversed_Table is new GNAT.Htable.Simple_HTable
+ (Header_Num => Entity_Header_Num,
+ Element => Boolean,
+ No_Element => False,
+ Key => Node_Id,
+ Hash => Node_Hash,
+ Equal => "=");
+ -- Hash table to record which nodes we have traversed, so we can avoid
+ -- traversing the same nodes repeatedly.
+
-----------------
- -- Entity_Hash --
+ -- Node_Hash --
-----------------
- function Entity_Hash (Id : Entity_Id) return Entity_Header_Num is
+ function Node_Hash (Id : Entity_Id) return Entity_Header_Num is
begin
return Entity_Header_Num (Id mod Entity_Table_Size);
- end Entity_Hash;
+ end Node_Hash;
---------------------------------
-- Analyze_Package_Body_Helper --
function Scan_Subprogram_Ref (N : Node_Id) return Traverse_Result;
-- Determine whether a node denotes a reference to a subprogram
- procedure Scan_Subprogram_Refs is
+ procedure Traverse_And_Scan_Subprogram_Refs is
new Traverse_Proc (Scan_Subprogram_Ref);
-- Subsidiary to routine Has_Referencer. Determine whether a node
-- contains references to a subprogram and record them.
-- WARNING: this is a very expensive routine as it performs a full
-- tree traversal.
+ procedure Scan_Subprogram_Refs (Node : Node_Id);
+ -- If we haven't already traversed Node, then mark it and traverse
+ -- it.
+
+ procedure Scan_Subprogram_Refs (Node : Node_Id) is
+ begin
+ if not Traversed_Table.Get (Node) then
+ Traversed_Table.Set (Node, True);
+ Traverse_And_Scan_Subprogram_Refs (Node);
+ end if;
+ end Scan_Subprogram_Refs;
+
--------------------
-- Has_Referencer --
--------------------
-- actual parameters of the instantiations matter here, and they are
-- present in the declarations list of the instantiated packages.
+ Traversed_Table.Reset;
Subprogram_Table.Reset;
Discard := Has_Referencer (Decls, Top_Level => True);
end Hide_Public_Entities;
(Current_Use_Clause (Associated_Node (N))))
then
Error_Msg_Node_1 := Entity (N);
- Error_Msg_NE ("ineffective use clause for package &?",
+ Error_Msg_NE ("use clause for package &? has no effect",
Curr, Entity (N));
end if;
else
Error_Msg_Node_1 := Etype (N);
- Error_Msg_NE ("ineffective use clause for }?",
+ Error_Msg_NE ("use clause for }? has no effect",
Curr, Etype (N));
end if;
end if;
N := Next (Actual_Id);
if Nkind (N) = N_Parameter_Association then
- return First_Named_Actual (Parent (Actual_Id));
+ -- In case of a build-in-place call, the call will no longer be a
+ -- call; it will have been rewritten.
+
+ if Nkind_In (Parent (Actual_Id),
+ N_Entry_Call_Statement,
+ N_Function_Call,
+ N_Procedure_Call_Statement)
+ then
+ return First_Named_Actual (Parent (Actual_Id));
+ else
+ return Empty;
+ end if;
else
return N;
end if;
--- /dev/null
+-- { dg-do compile }
+-- { dg-options "-gnatVi -gnatws" }
+
+with Validity_Check2_Pkg; use Validity_Check2_Pkg;
+
+procedure Validity_Check2 (R : access Rec) is
+begin
+ if Op_Code_To_Msg (R.Code) in Valid_Msg then
+ raise Program_Error;
+ end if;
+end;
--- /dev/null
+with Ada.unchecked_conversion;
+
+package Validity_Check2_Pkg is
+
+ type Op_Code is (One, Two, Three, Four);
+
+ subtype Valid_Msg is Integer range 0 .. 15;
+
+ function Op_Code_To_Msg is
+ new Ada.Unchecked_Conversion (Source => Op_code, Target => Valid_Msg);
+
+ type Rec is record
+ Code : Op_Code;
+ end record;
+
+end Validity_Check2_Pkg;
projects / gcc.git / commitdiff