end if;
end Is_Function_Type;
- -- Start of processing for Analyze_Explicit_Deference
+ -- Start of processing for Analyze_Explicit_Dereference
begin
Analyze (P);
Get_Next_Interp (I, It);
end loop;
- End_Interp_List;
-
-- Error if no interpretation of the prefix has an access type
if Etype (N) = Any_Type then
then
-- Name is a function call with no actuals, in a context that
-- requires deproceduring (including as an actual in an enclosing
- -- function or procedure call). We can conceive of pathological cases
+ -- function or procedure call). There are some pathological cases
-- where the prefix might include functions that return access to
-- subprograms and others that return a regular type. Disambiguation
- -- of those will have to take place in Resolve. See e.g. 7117-014.
+ -- of those has to take place in Resolve.
+ -- See e.g. 7117-014 and E317-001.
New_N :=
Make_Function_Call (Loc,
Rewrite (N, New_N);
Analyze (N);
+
+ elsif not Is_Function_Type
+ and then Is_Overloaded (N)
+ then
+ -- The prefix may include access to subprograms and other access
+ -- types. If the context selects the interpretation that is a call,
+ -- we cannot rewrite the node yet, but we include the result of
+ -- the call interpretation.
+
+ Get_First_Interp (N, I, It);
+ while Present (It.Nam) loop
+ if Ekind (Base_Type (It.Typ)) = E_Subprogram_Type
+ and then Etype (Base_Type (It.Typ)) /= Standard_Void_Type
+ then
+ Add_One_Interp (N, Etype (It.Typ), Etype (It.Typ));
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
end if;
-- A value of remote access-to-class-wide must not be dereferenced
then
Set_Etype (N, Etype (Comp));
- -- In all other cases, we currently build an actual subtype. It
- -- seems likely that many of these cases can be avoided, but
- -- right now, the front end makes direct references to the
+ -- If full analysis is not enabled, we do not generate an
+ -- actual subtype, because in the absence of expansion
+ -- reference to a formal of a protected type, for example,
+ -- will not be properly transformed, and will lead to
+ -- out-of-scope references in gigi.
+
+ -- In all other cases, we currently build an actual subtype.
+ -- It seems likely that many of these cases can be avoided,
+ -- but right now, the front end makes direct references to the
-- bounds (e.g. in generating a length check), and if we do
-- not make an actual subtype, we end up getting a direct
- -- reference to a discriminant which will not do.
+ -- reference to a discriminant, which will not do.
- else
+ elsif Full_Analysis then
Act_Decl :=
Build_Actual_Subtype_Of_Component (Etype (Comp), N);
Insert_Action (N, Act_Decl);
Set_Etype (N, Subt);
end;
end if;
+
+ -- If Full_Analysis not enabled, just set the Etype
+
+ else
+ Set_Etype (N, Etype (Comp));
end if;
return;
then
return;
- -- If the transformation fails, it will be necessary
- -- to redo the analysis with all errors enabled, to indicate
- -- candidate interpretations and reasons for each failure ???
+ -- If the transformation fails, it will be necessary to redo the
+ -- analysis with all errors enabled, to indicate candidate
+ -- interpretations and reasons for each failure ???
end if;
elsif Is_Private_Type (Prefix_Type) then
- -- Allow access only to discriminants of the type. If the
- -- type has no full view, gigi uses the parent type for
- -- the components, so we do the same here.
+ -- Allow access only to discriminants of the type. If the type has
+ -- no full view, gigi uses the parent type for the components, so we
+ -- do the same here.
if No (Full_View (Prefix_Type)) then
Entity_List := Root_Type (Base_Type (Prefix_Type));
elsif Is_Concurrent_Type (Prefix_Type) then
-- Prefix is concurrent type. Find visible operation with given name
- -- For a task, this can only include entries or discriminants if
- -- the task type is not an enclosing scope. If it is an enclosing
- -- scope (e.g. in an inner task) then all entities are visible, but
- -- the prefix must denote the enclosing scope, i.e. can only be
- -- a direct name or an expanded name.
+ -- For a task, this can only include entries or discriminants if the
+ -- task type is not an enclosing scope. If it is an enclosing scope
+ -- (e.g. in an inner task) then all entities are visible, but the
+ -- prefix must denote the enclosing scope, i.e. can only be a direct
+ -- name or an expanded name.
Set_Etype (Sel, Any_Type);
In_Scope := In_Open_Scopes (Prefix_Type);
Set_Original_Discriminant (Sel, Comp);
end if;
- -- For access type case, introduce explicit deference for
- -- more uniform treatment of entry calls.
+ -- For access type case, introduce explicit deference for more
+ -- uniform treatment of entry calls.
if Is_Access_Type (Etype (Name)) then
Insert_Explicit_Dereference (Name);
if Etype (N) = Any_Type then
- -- If the prefix is a single concurrent object, use its name in
- -- the error message, rather than that of its anonymous type.
+ -- If the prefix is a single concurrent object, use its name in the
+ -- error message, rather than that of its anonymous type.
if Is_Concurrent_Type (Prefix_Type)
and then Is_Internal_Name (Chars (Prefix_Type))
and then Prefix_Type /= Etype (Prefix_Type)
and then Is_Record_Type (Etype (Prefix_Type))
then
- -- If this is a derived formal type, the parent may have a
+ -- If this is a derived formal type, the parent may have
-- different visibility at this point. Try for an inherited
-- component before reporting an error.
-- If the iteration is given by a range, create temporaries and
-- assignment statements block to capture the bounds and perform
-- required finalization actions in case a bound includes a function
- -- call that uses the temporary stack.
+ -- call that uses the temporary stack. We first pre-analyze a copy of
+ -- the range in order to determine the expected type, and analyze
+ -- and resolve the original bounds.
procedure Check_Controlled_Array_Attribute (DS : Node_Id);
-- If the bounds are given by a 'Range reference on a function call
procedure Process_Bounds (R : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
+ R_Copy : constant Node_Id := New_Copy_Tree (R);
Lo : constant Node_Id := Low_Bound (R);
Hi : constant Node_Id := High_Bound (R);
New_Lo_Bound : Node_Id := Empty;
New_Hi_Bound : Node_Id := Empty;
- Typ : constant Entity_Id := Etype (R);
+ Typ : Entity_Id;
- function One_Bound (Bound : Node_Id) return Node_Id;
+ function One_Bound
+ (Original_Bound : Node_Id;
+ Analyzed_Bound : Node_Id) return Node_Id;
-- Create one declaration followed by one assignment statement
-- to capture the value of bound. We create a separate assignment
-- in order to force the creation of a block in case the bound
-- One_Bound --
---------------
- function One_Bound (Bound : Node_Id) return Node_Id is
+ function One_Bound
+ (Original_Bound : Node_Id;
+ Analyzed_Bound : Node_Id) return Node_Id
+ is
Assign : Node_Id;
Id : Entity_Id;
Decl : Node_Id;
-- part of the call to Make_Index (literal bounds may need to
-- be resolved to type Integer).
- if Nkind (Bound) = N_Integer_Literal
- or else Is_Entity_Name (Bound)
- or else Analyzed (Bound)
+ if Analyzed (Original_Bound) then
+ return Original_Bound;
+
+ elsif Nkind (Analyzed_Bound) = N_Integer_Literal
+ or else Is_Entity_Name (Analyzed_Bound)
then
- return Bound;
+ Analyze_And_Resolve (Original_Bound, Typ);
+ return Original_Bound;
+
+ else
+ Analyze_And_Resolve (Original_Bound, Typ);
end if;
Id :=
Assign :=
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Id, Loc),
- Expression => Relocate_Node (Bound));
+ Expression => Relocate_Node (Original_Bound));
- Save_Interps (Bound, Expression (Assign));
Insert_Before (Parent (N), Assign);
Analyze (Assign);
- Rewrite (Bound, New_Occurrence_Of (Id, Loc));
+ Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc));
if Nkind (Assign) = N_Assignment_Statement then
return Expression (Assign);
else
- return Bound;
+ return Original_Bound;
end if;
end One_Bound;
-- Start of processing for Process_Bounds
begin
- New_Lo_Bound := One_Bound (Lo);
- New_Hi_Bound := One_Bound (Hi);
+ -- Determine expected type of range by analyzing separate copy.
+
+ Set_Parent (R_Copy, Parent (R));
+ Pre_Analyze_And_Resolve (R_Copy);
+ Typ := Etype (R_Copy);
+ Set_Etype (R, Typ);
+
+ New_Lo_Bound := One_Bound (Lo, Low_Bound (R_Copy));
+ New_Hi_Bound := One_Bound (Hi, High_Bound (R_Copy));
-- Propagate staticness to loop range itself, in case the
-- corresponding subtype is static.
if Nkind (DS) = N_Range
and then Expander_Active
then
- Pre_Analyze_And_Resolve (DS);
Process_Bounds (DS);
else
Analyze (DS);
OSDN Git Service
