[Ada] improve handling of overloaded parameterless functions
Arnaud Charlet
charlet@adacore.com
Tue Mar 29 16:10:00 GMT 2005
Tested on i686-linux, committed on HEAD
The construct F.all can denote different constructs when F is an
overloaded parameterless function that returns an access type. If the
return type of F is an access_to_object, the construct means F().all,
that is to say a dereference of the result of the call. However, if
the return type of F is an access_to_function without parameters, then
the construct may be interpreted as an indirect call of the value
returned by F, that is to say (F().all)(). In order to resolve the
construct we must carry all interpretations during the first pass of
type resolution, and recover the proper tree according to the context.
The analysis of the explicit dereference builds the tree corresponding
to the first interpretation, but includes the result type of the second
in the list of interpretations. Resolution of the explicit_dereference
builds the tree corresponding to the second interpretation when needed.
Test case:
--
package B is
type T is access function return Boolean;
type TA is access all T;
function F return TA; -- F1
function F return T; -- F2
end;
package body B is
X : Integer := 0;
function example return boolean is
begin
X := X + 1;
return X mod 2 = 1;
end;
Ptr : aliased T := Example'access;
function F return TA is
begin
return Ptr'access;
end;
function F return T is
begin
return example'access;
end;
end;
with B;
with Text_IO; use Text_IO;
procedure C is
X : B.T := B.F.all; -- B.F1 ().all
Yes : Boolean := B.F.all; -- (B.F2 ().all)()
begin
put_line (boolean'image (Yes));
for J in 1 .. 10 loop
put_line (boolean'image X.all));
end loop;
end;
--
Execution of c.adb must produce:
TRUE
FALSE
TRUE
FALSE
TRUE
FALSE
TRUE
FALSE
TRUE
FALSE
TRUE
2005-03-29 Ed Schonberg <schonberg@adacore.com>
* sem_ch4.adb (Analyze_Selected_Component): Do not generate an actual
subtype if code is being pre-analyzed, to prevent un-expanded
references to protected formals, among others.
(Analyze_Explicit_Dereference): If the overloaded prefix includes some
interpretation that can be a call, include the result of the call as a
possible interpretation of the dereference.
* sem_ch5.adb (Process_Bounds): Determine type of range by
pre-analyzing a copy of the original range, and then analyze the range
with the expected type.
* sem_res.adb (Check_Parameterless_Call): For an explicit dereference
with an overloaded prefix where not all interpretations yield an
access to subprogram, do not rewrite node as a call.
(Resolve_Explicit_Dereference): Recognize the previous case and rewrite
the node as a call once the context identifies the interpretation of
the prefix whose call yields the context type.
(Valid_Conversion): For the case of a conversion between
local access-to-subprogram types, check subtype conformance using
Check_Subtype_Conformant instead of Subtype_Conformant, to have a more
detailed error message.
-------------- next part --------------
Index: sem_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch4.adb,v
retrieving revision 1.38
diff -u -p -r1.38 sem_ch4.adb
--- sem_ch4.adb 18 Mar 2005 11:51:32 -0000 1.38
+++ sem_ch4.adb 29 Mar 2005 15:37:47 -0000
@@ -1197,7 +1197,7 @@ package body Sem_Ch4 is
end if;
end Is_Function_Type;
- -- Start of processing for Analyze_Explicit_Deference
+ -- Start of processing for Analyze_Explicit_Dereference
begin
Analyze (P);
@@ -1251,8 +1251,6 @@ package body Sem_Ch4 is
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
@@ -1281,10 +1279,11 @@ package body Sem_Ch4 is
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,
@@ -1311,6 +1310,25 @@ package body Sem_Ch4 is
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
@@ -2652,14 +2670,20 @@ package body Sem_Ch4 is
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);
@@ -2681,6 +2705,11 @@ package body Sem_Ch4 is
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;
@@ -2697,17 +2726,17 @@ package body Sem_Ch4 is
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));
@@ -2747,11 +2776,11 @@ package body Sem_Ch4 is
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);
@@ -2780,8 +2809,8 @@ package body Sem_Ch4 is
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);
@@ -2809,8 +2838,8 @@ package body Sem_Ch4 is
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))
@@ -2828,7 +2857,7 @@ package body Sem_Ch4 is
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.
Index: sem_ch5.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch5.adb,v
retrieving revision 1.20
diff -u -p -r1.20 sem_ch5.adb
--- sem_ch5.adb 10 Feb 2005 13:50:41 -0000 1.20
+++ sem_ch5.adb 29 Mar 2005 15:37:47 -0000
@@ -1112,7 +1112,9 @@ package body Sem_Ch5 is
-- 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
@@ -1126,13 +1128,16 @@ package body Sem_Ch5 is
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
@@ -1142,7 +1147,10 @@ package body Sem_Ch5 is
-- 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;
@@ -1156,11 +1164,17 @@ package body Sem_Ch5 is
-- 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 :=
@@ -1188,26 +1202,32 @@ package body Sem_Ch5 is
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.
@@ -1332,7 +1352,6 @@ package body Sem_Ch5 is
if Nkind (DS) = N_Range
and then Expander_Active
then
- Pre_Analyze_And_Resolve (DS);
Process_Bounds (DS);
else
Analyze (DS);
Index: sem_res.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_res.adb,v
retrieving revision 1.36
diff -u -p -r1.36 sem_res.adb
--- sem_res.adb 18 Mar 2005 11:49:25 -0000 1.36
+++ sem_res.adb 29 Mar 2005 15:37:48 -0000
@@ -168,7 +168,9 @@ package body Sem_Res is
-- by other node rewriting procedures.
procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id);
- -- Resolve actuals of call, and add default expressions for missing ones
+ -- Resolve actuals of call, and add default expressions for missing ones.
+ -- N is the Node_Id for the subprogram call, and Nam is the entity of the
+ -- called subprogram.
procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id);
-- Called from Resolve_Call, when the prefix denotes an entry or element
@@ -626,7 +628,6 @@ package body Sem_Res is
F := First_Formal (Subp);
A := First_Actual (N);
-
while Present (F) and then Present (A) loop
if not Is_Entity_Name (A)
or else Entity (A) /= F
@@ -787,6 +788,42 @@ package body Sem_Res is
procedure Check_Parameterless_Call (N : Node_Id) is
Nam : Node_Id;
+ function Prefix_Is_Access_Subp return Boolean;
+ -- If the prefix is of an access_to_subprogram type, the node must be
+ -- rewritten as a call. Ditto if the prefix is overloaded and all its
+ -- interpretations are access to subprograms.
+
+ ---------------------------
+ -- Prefix_Is_Access_Subp --
+ ---------------------------
+
+ function Prefix_Is_Access_Subp return Boolean is
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ if not Is_Overloaded (N) then
+ return
+ Ekind (Etype (N)) = E_Subprogram_Type
+ and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type;
+ else
+ Get_First_Interp (N, I, It);
+ while Present (It.Typ) loop
+ if Ekind (It.Typ) /= E_Subprogram_Type
+ or else Base_Type (Etype (It.Typ)) = Standard_Void_Type
+ then
+ return False;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ return True;
+ end if;
+ end Prefix_Is_Access_Subp;
+
+ -- Start of processing for Check_Parameterless_Call
+
begin
-- Defend against junk stuff if errors already detected
@@ -832,9 +869,7 @@ package body Sem_Res is
-- procedure or entry.
or else
- (Nkind (N) = N_Explicit_Dereference
- and then Ekind (Etype (N)) = E_Subprogram_Type
- and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type)
+ (Nkind (N) = N_Explicit_Dereference and then Prefix_Is_Access_Subp)
-- Rewrite as call if it is a selected component which is a function,
-- this is the case of a call to a protected function (which may be
@@ -858,7 +893,7 @@ package body Sem_Res is
then
Nam := New_Copy (N);
- -- If overloaded, overload set belongs to new copy.
+ -- If overloaded, overload set belongs to new copy
Save_Interps (N, Nam);
@@ -2515,7 +2550,6 @@ package body Sem_Res is
begin
A := First_Actual (N);
F := First_Formal (Nam);
-
while Present (F) loop
if No (A) and then Needs_No_Actuals (Nam) then
null;
@@ -4796,9 +4830,11 @@ package body Sem_Res is
----------------------------------
procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is
- P : constant Node_Id := Prefix (N);
- I : Interp_Index;
- It : Interp;
+ Loc : constant Source_Ptr := Sloc (N);
+ New_N : Node_Id;
+ P : constant Node_Id := Prefix (N);
+ I : Interp_Index;
+ It : Interp;
begin
-- Now that we know the type, check that this is not a
@@ -4824,7 +4860,39 @@ package body Sem_Res is
Get_Next_Interp (I, It);
end loop;
- Resolve (P, It.Typ);
+ if Present (It.Typ) then
+ Resolve (P, It.Typ);
+ else
+ -- If no interpretation covers the designated type of the
+ -- prefix, this is the pathological case where not all
+ -- implementations of the prefix allow the interpretation
+ -- of the node as a call. Now that the expected type is known,
+ -- Remove other interpretations from prefix, rewrite it as
+ -- a call, and resolve again, so that the proper call node
+ -- is generated.
+
+ Get_First_Interp (P, I, It);
+ while Present (It.Typ) loop
+ if Ekind (It.Typ) /= E_Access_Subprogram_Type then
+ Remove_Interp (I);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ New_N :=
+ Make_Function_Call (Loc,
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => P),
+ Parameter_Associations => New_List);
+
+ Save_Interps (N, New_N);
+ Rewrite (N, New_N);
+ Analyze_And_Resolve (N, Typ);
+ return;
+ end if;
+
Set_Etype (N, Designated_Type (It.Typ));
else
@@ -5667,6 +5735,16 @@ package body Sem_Res is
Error_Msg_N ("value has extraneous low order digits", N);
end if;
+ -- Generate a warning if literal from source
+
+ if Is_Static_Expression (N)
+ and then Warn_On_Bad_Fixed_Value
+ then
+ Error_Msg_N
+ ("static fixed-point value is not a multiple of Small?",
+ N);
+ end if;
+
-- Replace literal by a value that is the exact representation
-- of a value of the type, i.e. a multiple of the small value,
-- by truncation, since Machine_Rounds is false for all GNAT
@@ -5678,6 +5756,8 @@ package body Sem_Res is
Realval => Small_Value (Typ) * Cint));
Set_Is_Static_Expression (N, Stat);
+
+
end if;
-- In all cases, set the corresponding integer field
@@ -6351,8 +6431,7 @@ package body Sem_Res is
Set_Etype (Operand, Standard_Duration);
end if;
- -- Resolve the real operand with largest available precision.
-
+ -- Resolve the real operand with largest available precision
if Etype (Right_Opnd (Operand)) = Universal_Real then
Rop := New_Copy_Tree (Right_Opnd (Operand));
else
@@ -6787,7 +6866,7 @@ package body Sem_Res is
T1 := Standard_Duration;
- -- Look for fixed-point types in enclosing scopes.
+ -- Look for fixed-point types in enclosing scopes
Scop := Current_Scope;
while Scop /= Standard_Standard loop
@@ -7219,19 +7298,16 @@ package body Sem_Res is
elsif (Ekind (Target_Type) = E_Access_Subprogram_Type
or else
Ekind (Target_Type) = E_Anonymous_Access_Subprogram_Type)
+ and then No (Corresponding_Remote_Type (Opnd_Type))
and then Conversion_Check
(Ekind (Base_Type (Opnd_Type)) = E_Access_Subprogram_Type,
"illegal operand for access subprogram conversion")
then
-- Check that the designated types are subtype conformant
- if not Subtype_Conformant (Designated_Type (Opnd_Type),
- Designated_Type (Target_Type))
- then
- Error_Msg_N
- ("operand type is not subtype conformant with target type",
- Operand);
- end if;
+ Check_Subtype_Conformant (New_Id => Designated_Type (Target_Type),
+ Old_Id => Designated_Type (Opnd_Type),
+ Err_Loc => N);
-- Check the static accessibility rule of 4.6(20)
More information about the Gcc-patches
mailing list