-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
-- Processing for OUT or IN OUT parameter
else
+ -- Kill current value indications for the temporary variable we
+ -- created, since we just passed it as an OUT parameter.
+
+ Kill_Current_Values (Temp);
+
-- If type conversion, use reverse conversion on exit
if Nkind (Actual) = N_Type_Conversion then
Set_First_Named_Actual (N, Actual_Expr);
if No (Prev) then
- if not Present (Parameter_Associations (N)) then
+ if No (Parameter_Associations (N)) then
Set_Parameter_Associations (N, New_List);
Append (Insert_Param, Parameter_Associations (N));
end if;
Check_Valid_Lvalue_Subscripts (Actual);
end if;
- -- Mark any scalar OUT parameter that is a simple variable
- -- as no longer known to be valid (unless the type is always
- -- valid). This reflects the fact that if an OUT parameter
- -- is never set in a procedure, then it can become invalid
- -- on return from the procedure.
+ -- Mark any scalar OUT parameter that is a simple variable as no
+ -- longer known to be valid (unless the type is always valid). This
+ -- reflects the fact that if an OUT parameter is never set in a
+ -- procedure, then it can become invalid on the procedure return.
if Ekind (Formal) = E_Out_Parameter
and then Is_Entity_Name (Actual)
Set_Is_Known_Valid (Entity (Actual), False);
end if;
- -- For an OUT or IN OUT parameter of an access type, if the
- -- actual is an entity, then it is no longer known to be non-null.
+ -- For an OUT or IN OUT parameter, if the actual is an entity, then
+ -- clear current values, since they can be clobbered. We are probably
+ -- doing this in more places than we need to, but better safe than
+ -- sorry when it comes to retaining bad current values!
if Ekind (Formal) /= E_In_Parameter
and then Is_Entity_Name (Actual)
- and then Is_Access_Type (Etype (Actual))
then
- Set_Is_Known_Non_Null (Entity (Actual), False);
+ Kill_Current_Values (Entity (Actual));
end if;
-- If the formal is class wide and the actual is an aggregate, force
Next_Formal (Formal);
end loop;
- -- If we are expanding a rhs of an assignement we need to check if
- -- tag propagation is needed. This code belongs theorically in Analyze
- -- Assignment but has to be done earlier (bottom-up) because the
- -- assignment might be transformed into a declaration for an uncons-
- -- trained value, if the expression is classwide.
+ -- If we are expanding a rhs of an assignment we need to check if tag
+ -- propagation is needed. You might expect this processing to be in
+ -- Analyze_Assignment but has to be done earlier (bottom-up) because the
+ -- assignment might be transformed to a declaration for an unconstrained
+ -- value if the expression is classwide.
if Nkind (N) = N_Function_Call
and then Is_Tag_Indeterminate (N)
end loop;
end if;
+ -- The below setting of Entity is suspect, see F109-018 discussion???
+
Set_Entity (Name (N), Parent_Subp);
if Is_Abstract (Parent_Subp)
-- call, or a protected function call. Protected procedure calls are
-- rewritten as entry calls and handled accordingly.
+ -- In Ada 2005, this may be an indirect call to an access parameter
+ -- that is an access_to_subprogram. In that case the anonymous type
+ -- has a scope that is a protected operation, but the call is a
+ -- regular one.
+
Scop := Scope (Subp);
if Nkind (N) /= N_Entry_Call_Statement
and then Is_Protected_Type (Scop)
+ and then Ekind (Subp) /= E_Subprogram_Type
then
-- If the call is an internal one, it is rewritten as a call to
-- to the corresponding unprotected subprogram.
end if;
end;
end if;
+
+ -- Special processing for Ada 2005 AI-329, which requires a call to
+ -- Raise_Exception to raise Constraint_Error if the Exception_Id is
+ -- null. Note that we never need to do this in GNAT mode, or if the
+ -- parameter to Raise_Exception is a use of Identity, since in these
+ -- cases we know that the parameter is never null.
+
+ if Ada_Version >= Ada_05
+ and then not GNAT_Mode
+ and then Is_RTE (Subp, RE_Raise_Exception)
+ and then (Nkind (First_Actual (N)) /= N_Attribute_Reference
+ or else Attribute_Name (First_Actual (N)) /= Name_Identity)
+ then
+ declare
+ RCE : constant Node_Id :=
+ Make_Raise_Constraint_Error (Loc,
+ Reason => CE_Null_Exception_Id);
+ begin
+ Insert_After (N, RCE);
+ Analyze (RCE);
+ end;
+ end if;
end Expand_Call;
--------------------------
Blk : Node_Id;
Bod : Node_Id;
Decl : Node_Id;
+ Decls : constant List_Id := New_List;
Exit_Lab : Entity_Id := Empty;
F : Entity_Id;
A : Node_Id;
Num_Ret : Int := 0;
Ret_Type : Entity_Id;
Targ : Node_Id;
+ Targ1 : Node_Id;
Temp : Entity_Id;
Temp_Typ : Entity_Id;
+ Is_Unc : constant Boolean :=
+ Is_Array_Type (Etype (Subp))
+ and then not Is_Constrained (Etype (Subp));
+ -- If the type returned by the function is unconstrained and the
+ -- call can be inlined, special processing is required.
+
+ procedure Find_Result;
+ -- For a function that returns an unconstrained type, retrieve the
+ -- name of the single variable that is the expression of a return
+ -- statement in the body of the function. Build_Body_To_Inline has
+ -- verified that this variable is unique, even in the presence of
+ -- multiple return statements.
+
procedure Make_Exit_Label;
-- Build declaration for exit label to be used in Return statements
function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean;
-- Determine whether a formal parameter is used only once in Orig_Bod
+ -----------------
+ -- Find_Result --
+ -----------------
+
+ procedure Find_Result is
+ Decl : Node_Id;
+ Id : Node_Id;
+
+ function Get_Return (N : Node_Id) return Traverse_Result;
+ -- Recursive function to locate return statements in body.
+
+ function Get_Return (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Return_Statement then
+ Id := Expression (N);
+ return Abandon;
+ else
+ return OK;
+ end if;
+ end Get_Return;
+
+ procedure Find_It is new Traverse_Proc (Get_Return);
+
+ -- Start of processing for Find_Result
+
+ begin
+ Find_It (Handled_Statement_Sequence (Orig_Bod));
+
+ -- At this point the body is unanalyzed. Traverse the list of
+ -- declarations to locate the defining_identifier for it.
+
+ Decl := First (Declarations (Blk));
+
+ while Present (Decl) loop
+ if Chars (Defining_Identifier (Decl)) = Chars (Id) then
+ Targ1 := Defining_Identifier (Decl);
+ exit;
+
+ else
+ Next (Decl);
+ end if;
+ end loop;
+ end Find_Result;
+
---------------------
-- Make_Exit_Label --
---------------------
Insert_After (Parent (Entity (N)), Blk);
elsif Nkind (Parent (N)) = N_Assignment_Statement
- and then Is_Entity_Name (Name (Parent (N)))
+ and then
+ (Is_Entity_Name (Name (Parent (N)))
+ or else
+ (Nkind (Name (Parent (N))) = N_Explicit_Dereference
+ and then Is_Entity_Name (Prefix (Name (Parent (N))))))
then
-- Replace assignment with the block
elsif Nkind (Parent (N)) = N_Object_Declaration then
Set_Expression (Parent (N), Empty);
Insert_After (Parent (N), Blk);
+
+ elsif Is_Unc then
+ Insert_Before (Parent (N), Blk);
end if;
end Rewrite_Function_Call;
Set_Declarations (Blk, New_List);
end if;
+ -- For the unconstrained case, capture the name of the local
+ -- variable that holds the result.
+
+ if Is_Unc then
+ Find_Result;
+ end if;
+
-- If this is a derived function, establish the proper return type
if Present (Orig_Subp)
Name => New_A);
end if;
- Prepend (Decl, Declarations (Blk));
+ Append (Decl, Decls);
Set_Renamed_Object (F, Temp);
end if;
-- declaration, create a temporary as a target. The declaration for
-- the temporary may be subsequently optimized away if the body is a
-- single expression, or if the left-hand side of the assignment is
- -- simple enough.
+ -- simple enough, i.e. an entity or an explicit dereference of one.
if Ekind (Subp) = E_Function then
if Nkind (Parent (N)) = N_Assignment_Statement
then
Targ := Name (Parent (N));
+ elsif Nkind (Parent (N)) = N_Assignment_Statement
+ and then Nkind (Name (Parent (N))) = N_Explicit_Dereference
+ and then Is_Entity_Name (Prefix (Name (Parent (N))))
+ then
+ Targ := Name (Parent (N));
+
else
-- Replace call with temporary and create its declaration
Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
Set_Is_Internal (Temp);
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Object_Definition =>
- New_Occurrence_Of (Ret_Type, Loc));
+ -- For the unconstrained case. the generated temporary has the
+ -- same constrained declaration as the result variable.
+ -- It may eventually be possible to remove that temporary and
+ -- use the result variable directly.
+
+ if Is_Unc then
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_Definition =>
+ New_Copy_Tree (Object_Definition (Parent (Targ1))));
+
+ Replace_Formals (Decl);
+
+ else
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_Definition =>
+ New_Occurrence_Of (Ret_Type, Loc));
+
+ Set_Etype (Temp, Ret_Type);
+ end if;
Set_No_Initialization (Decl);
- Insert_Action (N, Decl);
+ Append (Decl, Decls);
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Targ := Temp;
end if;
end if;
+ Insert_Actions (N, Decls);
+
-- Traverse the tree and replace formals with actuals or their thunks.
-- Attach block to tree before analysis and rewriting.
Rewrite_Procedure_Call (N, Blk);
else
Rewrite_Function_Call (N, Blk);
+
+ -- For the unconstrained case, the replacement of the call has been
+ -- made prior to the complete analysis of the generated declarations.
+ -- Propagate the proper type now.
+
+ if Is_Unc then
+ if Nkind (N) = N_Identifier then
+ Set_Etype (N, Etype (Entity (N)));
+ else
+ Set_Etype (N, Etype (Targ1));
+ end if;
+ end if;
end if;
Restore_Env;
Proc := Entity (Name (Parent (N)));
- F := First_Formal (Proc);
- A := First_Actual (Parent (N));
+ F := First_Formal (Proc);
+ A := First_Actual (Parent (N));
while A /= N loop
Next_Formal (F);
Next_Actual (A);
-- (Ada 2005): Register an interface primitive in a secondary dispatch
-- table. If Prim overrides an ancestor primitive of its associated
-- tagged-type then Ancestor_Iface_Prim indicates the entity of that
- -- immediate ancestor associated with the interface; otherwise Prim and
- -- Ancestor_Iface_Prim have the same info.
+ -- immediate ancestor associated with the interface.
procedure Register_Predefined_DT_Entry (Prim : Entity_Id);
-- (Ada 2005): Register a predefined primitive in all the secondary
Skip_Controlling_Formals => True)
and then DT_Position (Prim_Op) = DT_Position (E)
and then Etype (DTC_Entity (Prim_Op)) = RTE (RE_Tag)
- and then not Present (Abstract_Interface_Alias (Prim_Op))
+ and then No (Abstract_Interface_Alias (Prim_Op))
then
if Overriden_Op = Empty then
Overriden_Op := Prim_Op;
Thunk_Id : Entity_Id;
begin
- if not Present (Ancestor_Iface_Prim) then
+ -- Nothing to do if the run-time does not give support to abstract
+ -- interfaces.
+
+ if not (RTE_Available (RE_Interface_Tag)) then
+ return;
+ end if;
+
+ if No (Ancestor_Iface_Prim) then
Prim_Typ := Scope (DTC_Entity (Alias (Prim)));
Iface_Typ := Scope (DTC_Entity (Abstract_Interface_Alias (Prim)));
begin
Prim_Typ := Scope (DTC_Entity (Prim));
- if not Present (Access_Disp_Table (Prim_Typ))
- or else not Present (Abstract_Interfaces (Prim_Typ))
+ if No (Access_Disp_Table (Prim_Typ))
+ or else No (Abstract_Interfaces (Prim_Typ))
+ or else not RTE_Available (RE_Interface_Tag)
then
return;
end if;
Insert_After (N, New_Thunk);
Insert_After (New_Thunk,
Make_DT_Access_Action (Node (Iface_Typ),
- Action => Set_Prim_Op_Address,
+ Action => Set_Predefined_Prim_Op_Address,
Args => New_List (
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (Node (Iface_DT_Ptr), Loc)),
then
Check_Overriding_Operation (E);
+ -- Ada 95 case: Register the subprogram in the primary dispatch table
+
if Ada_Version < Ada_05 then
- Insert_After (N,
- Fill_DT_Entry (Sloc (N), Prim => E));
+
+ -- Do not register the subprogram in the dispatch table if we
+ -- are compiling with the No_Dispatching_Calls restriction.
+
+ if not Restriction_Active (No_Dispatching_Calls) then
+ Insert_After (N,
+ Fill_DT_Entry (Sloc (N), Prim => E));
+ end if;
+
+ -- Ada 2005 case: Register the subprogram in the secondary dispatch
+ -- tables associated with abstract interfaces.
else
declare
begin
-- There is no dispatch table associated with abstract
- -- interface types; each type implementing interfaces
- -- will fill the associated secondary DT entries.
+ -- interface types. Each type implementing interfaces will
+ -- fill the associated secondary DT entries.
if not Is_Interface (Typ)
or else Present (Alias (E))
else
-- Generate thunks for all the predefined operations
- if Is_Predefined_Dispatching_Operation (E) then
- Register_Predefined_DT_Entry (E);
+ if not Restriction_Active (No_Dispatching_Calls) then
+ if Is_Predefined_Dispatching_Operation (E) then
+ Register_Predefined_DT_Entry (E);
+ end if;
+
+ Insert_After (N,
+ Fill_DT_Entry (Sloc (N), Prim => E));
end if;
- Insert_After (N,
- Fill_DT_Entry (Sloc (N), Prim => E));
Check_Overriding_Inherited_Interfaces (E);
end if;
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
T1 : Entity_Id;
T2 : Entity_Id;
Decl : Node_Id;
- Ent : Entity_Id;
procedure Diagnose_Non_Variable_Lhs (N : Node_Id);
-- N is the node for the left hand side of an assignment, and it
-- is not a variable. This routine issues an appropriate diagnostic.
+ procedure Kill_Lhs;
+ -- This is called to kill current value settings of a simple variable
+ -- on the left hand side. We call it if we find any error in analyzing
+ -- the assignment, and at the end of processing before setting any new
+ -- current values in place.
+
procedure Set_Assignment_Type
(Opnd : Node_Id;
Opnd_Type : in out Entity_Id);
end if;
end Diagnose_Non_Variable_Lhs;
+ --------------
+ -- Kill_LHS --
+ --------------
+
+ procedure Kill_Lhs is
+ begin
+ if Is_Entity_Name (Lhs) then
+ declare
+ Ent : constant Entity_Id := Entity (Lhs);
+ begin
+ if Present (Ent) then
+ Kill_Current_Values (Ent);
+ end if;
+ end;
+ end if;
+ end Kill_Lhs;
+
-------------------------
-- Set_Assignment_Type --
-------------------------
begin
Analyze (Rhs);
Analyze (Lhs);
+
+ -- Start type analysis for assignment
+
T1 := Etype (Lhs);
-- In the most general case, both Lhs and Rhs can be overloaded, and we
if T1 = Any_Type then
Error_Msg_N
("no valid types for left-hand side for assignment", Lhs);
+ Kill_Lhs;
return;
end if;
end if;
and then Ekind (T1) = E_Incomplete_Type
then
Error_Msg_N ("invalid use of incomplete type", Lhs);
+ Kill_Lhs;
return;
end if;
-- Remaining steps are skipped if Rhs was syntactically in error
if Rhs = Error then
+ Kill_Lhs;
return;
end if;
if not Covers (T1, T2) then
Wrong_Type (Rhs, Etype (Lhs));
+ Kill_Lhs;
return;
end if;
end if;
if T1 = Any_Type or else T2 = Any_Type then
+ Kill_Lhs;
return;
end if;
Error_Msg_N ("dynamically tagged expression required!", Rhs);
end if;
- -- Tag propagation is done only in semantics mode only. If expansion
- -- is on, the rhs tag indeterminate function call has been expanded
- -- and tag propagation would have happened too late, so the
- -- propagation take place in expand_call instead.
+ -- Propagate the tag from a class-wide target to the rhs when the rhs
+ -- is a tag-indeterminate call.
- if not Expander_Active
- and then Is_Class_Wide_Type (T1)
+ if Is_Class_Wide_Type (T1)
and then Is_Tag_Indeterminate (Rhs)
then
Propagate_Tag (Lhs, Rhs);
if Is_Scalar_Type (T1) then
Apply_Scalar_Range_Check (Rhs, Etype (Lhs));
+ -- For array types, verify that lengths match. If the right hand side
+ -- if a function call that has been inlined, the assignment has been
+ -- rewritten as a block, and the constraint check will be applied to the
+ -- assignment within the block.
+
elsif Is_Array_Type (T1)
and then
(Nkind (Rhs) /= N_Type_Conversion
- or else Is_Constrained (Etype (Rhs)))
+ or else Is_Constrained (Etype (Rhs)))
+ and then
+ (Nkind (Rhs) /= N_Function_Call
+ or else Nkind (N) /= N_Block_Statement)
then
-- Assignment verifies that the length of the Lsh and Rhs are equal,
-- but of course the indices do not have to match. If the right-hand
Error_Msg_CRT ("composite assignment", N);
end if;
- -- One more step. Let's see if we have a simple assignment of a
- -- known at compile time value to a simple variable. If so, we
- -- can record the value as the current value providing that:
+ -- Final step. If left side is an entity, then we may be able to
+ -- reset the current tracked values to new safe values. We only have
+ -- something to do if the left side is an entity name, and expansion
+ -- has not modified the node into something other than an assignment,
+ -- and of course we only capture values if it is safe to do so.
- -- We still have a simple assignment statement (no expansion
- -- activity has modified it in some peculiar manner)
+ if Is_Entity_Name (Lhs)
+ and then Nkind (N) = N_Assignment_Statement
+ then
+ declare
+ Ent : constant Entity_Id := Entity (Lhs);
- -- The type is a discrete type
+ begin
+ if Safe_To_Capture_Value (N, Ent) then
- -- The assignment is to a named entity
+ -- If we are assigning an access type and the left side is an
+ -- entity, then make sure that the Is_Known_[Non_]Null flags
+ -- properly reflect the state of the entity after assignment.
- -- The value is known at compile time
+ if Is_Access_Type (T1) then
+ if Known_Non_Null (Rhs) then
+ Set_Is_Known_Non_Null (Ent, True);
- if Nkind (N) /= N_Assignment_Statement
- or else not Is_Discrete_Type (T1)
- or else not Is_Entity_Name (Lhs)
- or else not Compile_Time_Known_Value (Rhs)
- then
- return;
- end if;
+ elsif Known_Null (Rhs)
+ and then not Can_Never_Be_Null (Ent)
+ then
+ Set_Is_Known_Null (Ent, True);
+
+ else
+ Set_Is_Known_Null (Ent, False);
- Ent := Entity (Lhs);
+ if not Can_Never_Be_Null (Ent) then
+ Set_Is_Known_Non_Null (Ent, False);
+ end if;
+ end if;
- -- Capture value if safe to do so
+ -- For discrete types, we may be able to set the current value
+ -- if the value is known at compile time.
- if Safe_To_Capture_Value (N, Ent) then
- Set_Current_Value (Ent, Rhs);
+ elsif Is_Discrete_Type (T1)
+ and then Compile_Time_Known_Value (Rhs)
+ then
+ Set_Current_Value (Ent, Rhs);
+ else
+ Set_Current_Value (Ent, Empty);
+ end if;
+
+ -- If not safe to capture values, kill them
+
+ else
+ Kill_Lhs;
+ end if;
+ end;
end if;
end Analyze_Assignment;
New_Lo_Bound : Node_Id := Empty;
New_Hi_Bound : Node_Id := Empty;
Typ : Entity_Id;
+ Save_Analysis : Boolean;
function One_Bound
(Original_Bound : Node_Id;
begin
-- Determine expected type of range by analyzing separate copy
+ -- Do the analysis and resolution of the copy of the bounds with
+ -- expansion disabled, to prevent the generation of finalization
+ -- actions on each bound. This prevents memory leaks when the
+ -- bounds contain calls to functions returning controlled arrays.
Set_Parent (R_Copy, Parent (R));
- Pre_Analyze_And_Resolve (R_Copy);
+ Save_Analysis := Full_Analysis;
+ Full_Analysis := False;
+ Expander_Mode_Save_And_Set (False);
+
+ Analyze (R_Copy);
+
+ if Is_Overloaded (R_Copy) then
+
+ -- Apply preference rules for range of predefined integer types,
+ -- or diagnose true ambiguity.
+
+ declare
+ I : Interp_Index;
+ It : Interp;
+ Found : Entity_Id := Empty;
+
+ begin
+ Get_First_Interp (R_Copy, I, It);
+ while Present (It.Typ) loop
+ if Is_Discrete_Type (It.Typ) then
+ if No (Found) then
+ Found := It.Typ;
+ else
+ if Scope (Found) = Standard_Standard then
+ null;
+
+ elsif Scope (It.Typ) = Standard_Standard then
+ Found := It.Typ;
+
+ else
+ -- Both of them are user-defined
+
+ Error_Msg_N
+ ("ambiguous bounds in range of iteration",
+ R_Copy);
+ Error_Msg_N ("\possible interpretations:", R_Copy);
+ Error_Msg_NE ("\} ", R_Copy, Found);
+ Error_Msg_NE ("\} ", R_Copy, It.Typ);
+ exit;
+ end if;
+ end if;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+ end if;
+
+ Resolve (R_Copy);
+ Expander_Mode_Restore;
+ Full_Analysis := Save_Analysis;
+
Typ := Etype (R_Copy);
-- If the type of the discrete range is Universal_Integer, then
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
package body Sem_Ch6 is
+ -- The following flag is used to indicate that two formals in two
+ -- subprograms being checked for conformance differ only in that one is
+ -- an access parameter while the other is of a general access type with
+ -- the same designated type. In this case, if the rest of the signatures
+ -- match, a call to either subprogram may be ambiguous, which is worth
+ -- a warning. The flag is set in Compatible_Types, and the warning emitted
+ -- in New_Overloaded_Entity.
+
+ May_Hide_Profile : Boolean := False;
+
-----------------------
-- Local Subprograms --
-----------------------
procedure Check_Returns
(HSS : Node_Id;
Mode : Character;
- Err : out Boolean);
- -- Called to check for missing return statements in a function body, or
- -- for returns present in a procedure body which has No_Return set. L is
- -- the handled statement sequence for the subprogram body. This procedure
- -- checks all flow paths to make sure they either have return (Mode = 'F')
- -- or do not have a return (Mode = 'P'). The flag Err is set if there are
- -- any control paths not explicitly terminated by a return in the function
- -- case, and is True otherwise.
+ Err : out Boolean;
+ Proc : Entity_Id := Empty);
+ -- Called to check for missing return statements in a function body, or for
+ -- returns present in a procedure body which has No_Return set. L is the
+ -- handled statement sequence for the subprogram body. This procedure
+ -- checks all flow paths to make sure they either have return (Mode = 'F',
+ -- used for functions) or do not have a return (Mode = 'P', used for
+ -- No_Return procedures). The flag Err is set if there are any control
+ -- paths not explicitly terminated by a return in the function case, and is
+ -- True otherwise. Proc is the entity for the procedure case and is used
+ -- in posting the warning message.
function Conforming_Types
(T1 : Entity_Id;
Error_Msg_N
("cannot return a local value by reference?", N);
Error_Msg_NE
- ("& will be raised at run time?!",
+ ("\& will be raised at run time?",
N, Standard_Program_Error);
end if;
(Etype (First_Entity (Spec_Id))));
end if;
- -- Comment needed here, since this is not Ada 2005 stuff! ???
+ -- Ada 2005: A formal that is an access parameter may have a
+ -- designated type imported through a limited_with clause, while
+ -- the body has a regular with clause. Update the types of the
+ -- formals accordingly, so that the non-limited view of each type
+ -- is available in the body. We have already verified that the
+ -- declarations are type-conformant.
+
+ if Ada_Version >= Ada_05 then
+ declare
+ F_Spec : Entity_Id;
+ F_Body : Entity_Id;
+
+ begin
+ F_Spec := First_Formal (Spec_Id);
+ F_Body := First_Formal (Body_Id);
+
+ while Present (F_Spec) loop
+ if Ekind (Etype (F_Spec)) = E_Anonymous_Access_Type
+ and then
+ From_With_Type (Designated_Type (Etype (F_Spec)))
+ then
+ Set_Etype (F_Spec, Etype (F_Body));
+ end if;
+
+ Next_Formal (F_Spec);
+ Next_Formal (F_Body);
+ end loop;
+ end;
+ end if;
+
+ -- Now make the formals visible, and place subprogram
+ -- on scope stack.
Install_Formals (Spec_Id);
Last_Formal := Last_Entity (Spec_Id);
and then Present (Spec_Id)
and then No_Return (Spec_Id)
then
- Check_Returns (HSS, 'P', Missing_Ret);
+ Check_Returns (HSS, 'P', Missing_Ret, Spec_Id);
end if;
-- Now we are going to check for variables that are never modified in
-- conflict with subsequent inlinings, so that it is unsafe to try to
-- inline in such a case.
+ function Has_Single_Return return Boolean;
+ -- In general we cannot inline functions that return unconstrained
+ -- type. However, we can handle such functions if all return statements
+ -- return a local variable that is the only declaration in the body
+ -- of the function. In that case the call can be replaced by that
+ -- local variable as is done for other inlined calls.
+
procedure Remove_Pragmas;
-- A pragma Unreferenced that mentions a formal parameter has no
-- meaning when the body is inlined and the formals are rewritten.
return False;
end Has_Pending_Instantiation;
+ ------------------------
+ -- Has_Single_Return --
+ ------------------------
+
+ function Has_Single_Return return Boolean is
+ Return_Statement : Node_Id := Empty;
+
+ function Check_Return (N : Node_Id) return Traverse_Result;
+
+ ------------------
+ -- Check_Return --
+ ------------------
+
+ function Check_Return (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Return_Statement then
+ if Present (Expression (N))
+ and then Is_Entity_Name (Expression (N))
+ then
+ if No (Return_Statement) then
+ Return_Statement := N;
+ return OK;
+
+ elsif Chars (Expression (N)) =
+ Chars (Expression (Return_Statement))
+ then
+ return OK;
+
+ else
+ return Abandon;
+ end if;
+
+ else
+ -- Expression has wrong form
+
+ return Abandon;
+ end if;
+
+ else
+ return OK;
+ end if;
+ end Check_Return;
+
+ function Check_All_Returns is new Traverse_Func (Check_Return);
+
+ -- Start of processing for Has_Single_Return
+
+ begin
+ return Check_All_Returns (N) = OK;
+ end Has_Single_Return;
+
--------------------
-- Remove_Pragmas --
--------------------
and then not Is_Scalar_Type (Etype (Subp))
and then not Is_Access_Type (Etype (Subp))
and then not Is_Constrained (Etype (Subp))
+ and then not Has_Single_Return
then
Cannot_Inline
("cannot inline & (unconstrained return type)?", N, Subp);
procedure Check_Returns
(HSS : Node_Id;
Mode : Character;
- Err : out Boolean)
+ Err : out Boolean;
+ Proc : Entity_Id := Empty)
is
Handler : Node_Id;
-- missing return curious, and raising Program_Error does not
-- seem such a bad behavior if this does occur.
+ -- Note that in the Ada 2005 case for Raise_Exception, the actual
+ -- behavior will be to raise Constraint_Error (see AI-329).
+
if Is_RTE (Entity (Name (Last_Stm)), RE_Raise_Exception)
or else
Is_RTE (Entity (Name (Last_Stm)), RE_Reraise_Occurrence)
-- If we fall through, issue appropriate message
if Mode = 'F' then
-
if not Raise_Exception_Call then
Error_Msg_N
- ("?RETURN statement missing following this statement!",
+ ("?RETURN statement missing following this statement",
Last_Stm);
Error_Msg_N
("\?Program_Error may be raised at run time",
Err := True;
+ -- Otherwise we have the case of a procedure marked No_Return
+
else
Error_Msg_N
- ("implied return after this statement not allowed (No_Return)",
+ ("?implied return after this statement will raise Program_Error",
Last_Stm);
+ Error_Msg_NE
+ ("?procedure & is marked as No_Return",
+ Last_Stm, Proc);
+
+ declare
+ RE : constant Node_Id :=
+ Make_Raise_Program_Error (Sloc (Last_Stm),
+ Reason => PE_Implicit_Return);
+ begin
+ Insert_After (Last_Stm, RE);
+ Analyze (RE);
+ end;
end if;
end Check_Statement_Sequence;
-- Otherwise definitely no match
else
+ if ((Ekind (Type_1) = E_Anonymous_Access_Type
+ and then Is_Access_Type (Type_2))
+ or else (Ekind (Type_2) = E_Anonymous_Access_Type
+ and then Is_Access_Type (Type_1)))
+ and then
+ Conforming_Types
+ (Designated_Type (Type_1), Designated_Type (Type_2), Ctype)
+ then
+ May_Hide_Profile := True;
+ end if;
+
return False;
end if;
end Conforming_Types;
or else
Explicit_Suppress (Scope (E), Accessibility_Check))
and then
- (not Present (P_Formal)
+ (No (P_Formal)
or else Present (Extra_Accessibility (P_Formal)))
then
-- Temporary kludge: for now we avoid creating the extra formal
procedure Install_Entity (E : Entity_Id) is
Prev : constant Entity_Id := Current_Entity (E);
-
begin
Set_Is_Immediately_Visible (E);
Set_Current_Entity (E);
procedure Install_Formals (Id : Entity_Id) is
F : Entity_Id;
-
begin
F := First_Formal (Id);
-
while Present (F) loop
Install_Entity (F);
Next_Formal (F);
Next_Formal (Formal);
end loop;
- if not Present (G_Typ) and then Ekind (Prev_E) = E_Function then
+ if No (G_Typ) and then Ekind (Prev_E) = E_Function then
G_Typ := Get_Generic_Parent_Type (Base_Type (Etype (Prev_E)));
end if;
-- formal ancestor type, so the new subprogram is
-- overriding.
- if not Present (P_Formal)
- and then not Present (N_Formal)
+ if No (P_Formal)
+ and then No (N_Formal)
and then (Ekind (New_E) /= E_Function
or else
Types_Correspond
Formals : List_Id;
Op_Name : Entity_Id;
- A : Entity_Id;
- B : Entity_Id;
+ FF : constant Entity_Id := First_Formal (S);
+ NF : constant Entity_Id := Next_Formal (FF);
begin
- -- Check that equality was properly defined
+ -- Check that equality was properly defined, ignore call if not
- if No (Next_Formal (First_Formal (S))) then
+ if No (NF) then
return;
end if;
- A := Make_Defining_Identifier (Loc, Chars (First_Formal (S)));
- B := Make_Defining_Identifier (Loc,
- Chars (Next_Formal (First_Formal (S))));
-
- Op_Name := Make_Defining_Operator_Symbol (Loc, Name_Op_Ne);
-
- Formals := New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => A,
- Parameter_Type =>
- New_Reference_To (Etype (First_Formal (S)), Loc)),
-
- Make_Parameter_Specification (Loc,
- Defining_Identifier => B,
- Parameter_Type =>
- New_Reference_To (Etype (Next_Formal (First_Formal (S))), Loc)));
-
- Decl :=
- Make_Subprogram_Declaration (Loc,
- Specification =>
- Make_Function_Specification (Loc,
- Defining_Unit_Name => Op_Name,
- Parameter_Specifications => Formals,
- Result_Definition => New_Reference_To (Standard_Boolean, Loc)));
-
- -- Insert inequality right after equality if it is explicit or after
- -- the derived type when implicit. These entities are created only for
- -- visibility purposes, and eventually replaced in the course of
- -- expansion, so they do not need to be attached to the tree and seen
- -- by the back-end. Keeping them internal also avoids spurious freezing
- -- problems. The declaration is inserted in the tree for analysis, and
- -- removed afterwards. If the equality operator comes from an explicit
- -- declaration, attach the inequality immediately after. Else the
- -- equality is inherited from a derived type declaration, so insert
- -- inequality after that declaration.
-
- if No (Alias (S)) then
- Insert_After (Unit_Declaration_Node (S), Decl);
- elsif Is_List_Member (Parent (S)) then
- Insert_After (Parent (S), Decl);
- else
- Insert_After (Parent (Etype (First_Formal (S))), Decl);
- end if;
+ declare
+ A : constant Entity_Id :=
+ Make_Defining_Identifier (Sloc (FF),
+ Chars => Chars (FF));
+
+ B : constant Entity_Id :=
+ Make_Defining_Identifier (Sloc (NF),
+ Chars => Chars (NF));
+
+ begin
+ Op_Name := Make_Defining_Operator_Symbol (Loc, Name_Op_Ne);
+
+ Formals := New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => A,
+ Parameter_Type =>
+ New_Reference_To (Etype (First_Formal (S)),
+ Sloc (Etype (First_Formal (S))))),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => B,
+ Parameter_Type =>
+ New_Reference_To (Etype (Next_Formal (First_Formal (S))),
+ Sloc (Etype (Next_Formal (First_Formal (S)))))));
+
+ Decl :=
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Op_Name,
+ Parameter_Specifications => Formals,
+ Result_Definition =>
+ New_Reference_To (Standard_Boolean, Loc)));
+
+ -- Insert inequality right after equality if it is explicit or after
+ -- the derived type when implicit. These entities are created only
+ -- for visibility purposes, and eventually replaced in the course of
+ -- expansion, so they do not need to be attached to the tree and seen
+ -- by the back-end. Keeping them internal also avoids spurious
+ -- freezing problems. The declaration is inserted in the tree for
+ -- analysis, and removed afterwards. If the equality operator comes
+ -- from an explicit declaration, attach the inequality immediately
+ -- after. Else the equality is inherited from a derived type
+ -- declaration, so insert inequality after that declaration.
+
+ if No (Alias (S)) then
+ Insert_After (Unit_Declaration_Node (S), Decl);
+ elsif Is_List_Member (Parent (S)) then
+ Insert_After (Parent (S), Decl);
+ else
+ Insert_After (Parent (Etype (First_Formal (S))), Decl);
+ end if;
- Mark_Rewrite_Insertion (Decl);
- Set_Is_Intrinsic_Subprogram (Op_Name);
- Analyze (Decl);
- Remove (Decl);
- Set_Has_Completion (Op_Name);
- Set_Corresponding_Equality (Op_Name, S);
- Set_Is_Abstract (Op_Name, Is_Abstract (S));
+ Mark_Rewrite_Insertion (Decl);
+ Set_Is_Intrinsic_Subprogram (Op_Name);
+ Analyze (Decl);
+ Remove (Decl);
+ Set_Has_Completion (Op_Name);
+ Set_Corresponding_Equality (Op_Name, S);
+ Set_Is_Abstract (Op_Name, Is_Abstract (S));
+ end;
end Make_Inequality_Operator;
----------------------
elsif not Is_Alias_Interface
and then Type_Conformant (E, S)
+
+ -- Ada 2005 (AI-251): Do not consider here entities that cover
+ -- abstract interface primitives. They will be handled after
+ -- the overriden entity is found (see comments bellow inside
+ -- this subprogram).
+
+ and then not (Is_Subprogram (E)
+ and then Present (Abstract_Interface_Alias (E)))
then
-- If the old and new entities have the same profile and one
-- is not the body of the other, then this is an error, unless
if Is_Non_Overriding_Operation (E, S) then
Enter_Overloaded_Entity (S);
- if not Present (Derived_Type)
+ if No (Derived_Type)
or else Is_Tagged_Type (Derived_Type)
then
Check_Dispatching_Operation (S, Empty);
-- E is inherited.
if Comes_From_Source (S) then
- if Present (Alias (E)) then
+ if Present (Alias (E)) then
Set_Overridden_Operation (S, Alias (E));
else
Set_Overridden_Operation (S, E);
Check_Dispatching_Operation (S, E);
+ -- AI-251: Handle the case in which the entity
+ -- overrides a primitive operation that covered
+ -- several abstract interface primitives.
+
+ declare
+ E1 : Entity_Id;
+ begin
+ E1 := Current_Entity_In_Scope (S);
+ while Present (E1) loop
+ if Is_Subprogram (E1)
+ and then Present
+ (Abstract_Interface_Alias (E1))
+ and then Alias (E1) = E
+ then
+ Set_Alias (E1, S);
+ end if;
+
+ E1 := Homonym (E1);
+ end loop;
+ end;
+
else
Check_Dispatching_Operation (S, Empty);
end if;
end if;
else
- null;
+ -- If one subprogram has an access parameter and the other
+ -- a parameter of an access type, calls to either might be
+ -- ambiguous. Verify that parameters match except for the
+ -- access parameter.
+
+ if May_Hide_Profile then
+ declare
+ F1 : Entity_Id;
+ F2 : Entity_Id;
+ begin
+ F1 := First_Formal (S);
+ F2 := First_Formal (E);
+ while Present (F1) and then Present (F2) loop
+ if Is_Access_Type (Etype (F1)) then
+ if not Is_Access_Type (Etype (F2))
+ or else not Conforming_Types
+ (Designated_Type (Etype (F1)),
+ Designated_Type (Etype (F2)),
+ Type_Conformant)
+ then
+ May_Hide_Profile := False;
+ end if;
+
+ elsif
+ not Conforming_Types
+ (Etype (F1), Etype (F2), Type_Conformant)
+ then
+ May_Hide_Profile := False;
+ end if;
+
+ Next_Formal (F1);
+ Next_Formal (F2);
+ end loop;
+
+ if May_Hide_Profile
+ and then No (F1)
+ and then No (F2)
+ then
+ Error_Msg_NE ("calls to& may be ambiguous?", S, S);
+ end if;
+ end;
+ end if;
end if;
Prev_Vis := E;
-- operation was dispatching), so we don't call
-- Check_Dispatching_Operation in that case.
- if not Present (Derived_Type)
+ if No (Derived_Type)
or else Is_Tagged_Type (Derived_Type)
then
Check_Dispatching_Operation (S, Empty);
is
Result : Boolean;
begin
+ May_Hide_Profile := False;
+
Check_Conformance
(New_Id, Old_Id, Type_Conformant, False, Result,
Skip_Controlling_Formals => Skip_Controlling_Formals);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
-- Give list of candidate interpretations when a character literal cannot
-- be resolved.
- procedure Check_Direct_Boolean_Op (N : Node_Id);
- -- N is a binary operator node which may possibly operate on Boolean
- -- operands. If the operator does have Boolean operands, then a call is
- -- made to check the restriction No_Direct_Boolean_Operators.
-
procedure Check_Discriminant_Use (N : Node_Id);
-- Enforce the restrictions on the use of discriminants when constraining
-- a component of a discriminated type (record or concurrent type).
-- universal must be checked for visibility during resolution
-- because their type is not determinable based on their operands.
+ procedure Check_Fully_Declared_Prefix
+ (Typ : Entity_Id;
+ Pref : Node_Id);
+ -- Check that the type of the prefix of a dereference is not incomplete
+
function Check_Infinite_Recursion (N : Node_Id) return Boolean;
-- Given a call node, N, which is known to occur immediately within the
-- subprogram being called, determines whether it is a detectable case of
end if;
end Analyze_And_Resolve;
- -----------------------------
- -- Check_Direct_Boolean_Op --
- -----------------------------
-
- procedure Check_Direct_Boolean_Op (N : Node_Id) is
- begin
- if Nkind (N) in N_Op
- and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean
- then
- Check_Restriction (No_Direct_Boolean_Operators, N);
- end if;
- end Check_Direct_Boolean_Op;
-
----------------------------
-- Check_Discriminant_Use --
----------------------------
-- Check that it is the high bound
if N /= High_Bound (PN)
- or else not Present (Discriminant_Default_Value (Disc))
+ or else No (Discriminant_Default_Value (Disc))
then
goto No_Danger;
end if;
end if;
end Check_For_Visible_Operator;
+ ----------------------------------
+ -- Check_Fully_Declared_Prefix --
+ ----------------------------------
+
+ procedure Check_Fully_Declared_Prefix
+ (Typ : Entity_Id;
+ Pref : Node_Id)
+ is
+ begin
+ -- Check that the designated type of the prefix of a dereference is
+ -- not an incomplete type. This cannot be done unconditionally, because
+ -- dereferences of private types are legal in default expressions. This
+ -- case is taken care of in Check_Fully_Declared, called below. There
+ -- are also 2005 cases where it is legal for the prefix to be unfrozen.
+
+ -- This consideration also applies to similar checks for allocators,
+ -- qualified expressions, and type conversions.
+
+ -- An additional exception concerns other per-object expressions that
+ -- are not directly related to component declarations, in particular
+ -- representation pragmas for tasks. These will be per-object
+ -- expressions if they depend on discriminants or some global entity.
+ -- If the task has access discriminants, the designated type may be
+ -- incomplete at the point the expression is resolved. This resolution
+ -- takes place within the body of the initialization procedure, where
+ -- the discriminant is replaced by its discriminal.
+
+ if Is_Entity_Name (Pref)
+ and then Ekind (Entity (Pref)) = E_In_Parameter
+ then
+ null;
+
+ -- Ada 2005 (AI-326): Tagged incomplete types allowed. The wrong usages
+ -- are handled by Analyze_Access_Attribute, Analyze_Assignment,
+ -- Analyze_Object_Renaming, and Freeze_Entity.
+
+ elsif Ada_Version >= Ada_05
+ and then Is_Entity_Name (Pref)
+ and then Ekind (Directly_Designated_Type (Etype (Pref))) =
+ E_Incomplete_Type
+ and then Is_Tagged_Type (Directly_Designated_Type (Etype (Pref)))
+ then
+ null;
+ else
+ Check_Fully_Declared (Typ, Parent (Pref));
+ end if;
+ end Check_Fully_Declared_Prefix;
+
------------------------------
-- Check_Infinite_Recursion --
------------------------------
Error := True;
end if;
+ -- Ada 2005, AI-420: Predefined equality on Universal_Access
+ -- is available.
+
+ elsif Ada_Version >= Ada_05
+ and then (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne)
+ and then Ekind (Etype (Act1)) = E_Anonymous_Access_Type
+ then
+ null;
+
else
Opnd_Type := Base_Type (Etype (Right_Opnd (Op_Node)));
-- Move to next interpretation
- exit Interp_Loop when not Present (It.Typ);
+ exit Interp_Loop when No (It.Typ);
Get_Next_Interp (I, It);
end loop Interp_Loop;
Set_First_Named_Actual (N, Actval);
if No (Prev) then
- if not Present (Parameter_Associations (N)) then
+ if No (Parameter_Associations (N)) then
Set_Parameter_Associations (N, New_List (Assoc));
else
Append (Assoc, Parameter_Associations (N));
-- the tag check to occur and no temporary will be needed (no
-- representation change can occur) and the parameter is passed by
-- reference, so we go ahead and resolve the type conversion.
- -- Another excpetion is the case of reference to component or
+ -- Another exception is the case of reference to component or
-- subcomponent of a bit-packed array, in which case we want to
-- defer expansion to the point the in and out assignments are
-- performed.
end if;
end if;
+ -- (Ada 2005: AI-251): If the actual is an allocator whose
+ -- directly designated type is a class-wide interface, we build
+ -- an anonymous access type to use it as the type of the
+ -- allocator. Later, when the subprogram call is expanded, if
+ -- the interface has a secondary dispatch table the expander
+ -- will add a type conversion to force the correct displacement
+ -- of the pointer.
+
+ if Nkind (A) = N_Allocator then
+ declare
+ DDT : constant Entity_Id :=
+ Directly_Designated_Type (Base_Type (Etype (F)));
+ New_Itype : Entity_Id;
+ begin
+ if Is_Class_Wide_Type (DDT)
+ and then Is_Interface (DDT)
+ then
+ New_Itype := Create_Itype (E_Anonymous_Access_Type, A);
+ Set_Etype (New_Itype, Etype (A));
+ Init_Size_Align (New_Itype);
+ Set_Directly_Designated_Type (New_Itype,
+ Directly_Designated_Type (Etype (A)));
+ Set_Etype (A, New_Itype);
+ end if;
+ end;
+ end if;
+
Resolve (A, Etype (F));
end if;
if In_Instance_Body then
Error_Msg_N ("?type in allocator has deeper level than" &
" designated class-wide type", E);
- Error_Msg_N ("?Program_Error will be raised at run time", E);
+ Error_Msg_N ("\?Program_Error will be raised at run time",
+ E);
Rewrite (N,
Make_Raise_Program_Error (Sloc (N),
Reason => PE_Accessibility_Check_Failed));
declare
Loc : constant Source_Ptr := Sloc (N);
begin
- Error_Msg_N ("?allocation from empty storage pool!", N);
- Error_Msg_N ("?Storage_Error will be raised at run time!", N);
+ Error_Msg_N ("?allocation from empty storage pool", N);
+ Error_Msg_N ("\?Storage_Error will be raised at run time", N);
Insert_Action (N,
Make_Raise_Storage_Error (Loc,
Reason => SE_Empty_Storage_Pool));
and then not Is_Controlling_Limited_Procedure (Nam)
then
Error_Msg_N
- ("entry call, entry renaming or dispatching primitive " &
- "of limited or synchronized interface required", N);
+ ("entry call or dispatching primitive of interface required", N);
end if;
end if;
then
Set_Has_Recursive_Call (Nam);
Error_Msg_N ("possible infinite recursion?", N);
- Error_Msg_N ("Storage_Error may be raised at run time?", N);
+ Error_Msg_N ("\Storage_Error may be raised at run time?", N);
end if;
exit;
-- for it, precisely because we will not do it within the init proc
-- itself.
- if Expander_Active
+ -- If the subprogram is marked Inlined_Always, then even if it returns
+ -- an unconstrained type the call does not require use of the secondary
+ -- stack.
+
+ if Is_Inlined (Nam)
+ and then Present (First_Rep_Item (Nam))
+ and then Nkind (First_Rep_Item (Nam)) = N_Pragma
+ and then Chars (First_Rep_Item (Nam)) = Name_Inline_Always
+ then
+ null;
+
+ elsif Expander_Active
and then Is_Type (Etype (Nam))
and then Requires_Transient_Scope (Etype (Nam))
and then Ekind (Nam) /= E_Enumeration_Literal
Check_Unset_Reference (R);
Generate_Operator_Reference (N, T);
Eval_Relational_Op (N);
- Check_Direct_Boolean_Op (N);
end if;
end if;
end Resolve_Comparison_Op;
Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N));
end if;
- Check_Direct_Boolean_Op (N);
+ -- Ada 2005: If one operand is an anonymous access type, convert
+ -- the other operand to it, to ensure that the underlying types
+ -- match in the back-end.
+ -- We apply the same conversion in the case one of the operands is
+ -- a private subtype of the type of the other.
+
+ if Ekind (T) = E_Anonymous_Access_Type
+ or else Is_Private_Type (T)
+ then
+ if Etype (L) /= T then
+ Rewrite (L,
+ Make_Unchecked_Type_Conversion (Sloc (L),
+ Subtype_Mark => New_Occurrence_Of (T, Sloc (L)),
+ Expression => Relocate_Node (L)));
+ Analyze_And_Resolve (L, T);
+ end if;
+
+ if (Etype (R)) /= T then
+ Rewrite (R,
+ Make_Unchecked_Type_Conversion (Sloc (R),
+ Subtype_Mark => New_Occurrence_Of (Etype (L), Sloc (R)),
+ Expression => Relocate_Node (R)));
+ Analyze_And_Resolve (R, T);
+ end if;
+ end if;
end if;
end Resolve_Equality_Op;
It : Interp;
begin
- -- Now that we know the type, check that this is not dereference of an
- -- uncompleted type. Note that this is not entirely correct, because
- -- dereferences of private types are legal in default expressions. This
- -- exception is taken care of in Check_Fully_Declared.
-
- -- This consideration also applies to similar checks for allocators,
- -- qualified expressions, and type conversions.
-
- -- An additional exception concerns other per-object expressions that
- -- are not directly related to component declarations, in particular
- -- representation pragmas for tasks. These will be per-object
- -- expressions if they depend on discriminants or some global entity.
- -- If the task has access discriminants, the designated type may be
- -- incomplete at the point the expression is resolved. This resolution
- -- takes place within the body of the initialization procedure, where
- -- the discriminant is replaced by its discriminal.
-
- if Is_Entity_Name (Prefix (N))
- and then Ekind (Entity (Prefix (N))) = E_In_Parameter
- then
- null;
-
- -- Ada 2005 (AI-326): Tagged incomplete types allowed. The wrong usages
- -- are handled by Analyze_Access_Attribute, Analyze_Assignment, Analyze_
- -- Object_Renaming, and Freeze_Entity.
-
- elsif Ada_Version >= Ada_05
- and then Is_Entity_Name (Prefix (N))
- and then Ekind (Directly_Designated_Type (Etype (Prefix (N))))
- = E_Incomplete_Type
- and then Is_Tagged_Type (Directly_Designated_Type (Etype (Prefix (N))))
- then
- null;
- else
- Check_Fully_Declared (Typ, N);
- end if;
+ Check_Fully_Declared_Prefix (Typ, P);
if Is_Overloaded (P) then
procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is
B_Typ : Entity_Id;
+ N_Opr : constant Node_Kind := Nkind (N);
begin
-- Predefined operations on scalar types yield the base type. On the
Set_Etype (N, B_Typ);
Generate_Operator_Reference (N, B_Typ);
Eval_Logical_Op (N);
- Check_Direct_Boolean_Op (N);
+
+ -- Check for violation of restriction No_Direct_Boolean_Operators
+ -- if the operator was not eliminated by the Eval_Logical_Op call.
+
+ if Nkind (N) = N_Opr
+ and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean
+ then
+ Check_Restriction (No_Direct_Boolean_Operators, N);
+ end if;
end Resolve_Logical_Op;
---------------------------
-- type I is interface;
-- type T is tagged ...
- -- function Test (O : in I'Class) is
+ -- function Test (O : I'Class) is
-- begin
-- return O in T'Class.
-- end Test;
else
It1 := It;
- if Scope (Comp1) /= It1.Typ then
+ -- There may be an implicit dereference. Retrieve
+ -- designated record type.
+
+ if Is_Access_Type (It1.Typ) then
+ T := Designated_Type (It1.Typ);
+ else
+ T := It1.Typ;
+ end if;
+
+ if Scope (Comp1) /= T then
-- Resolution chooses the new interpretation.
-- Find the component with the right name.
- Comp1 := First_Entity (It1.Typ);
+ Comp1 := First_Entity (T);
while Present (Comp1)
and then Chars (Comp1) /= Chars (S)
loop
Resolve (P, T);
end if;
- -- If prefix is an access type, the node will be transformed into
- -- an explicit dereference during expansion. The type of the node
- -- is the designated type of that of the prefix.
+ -- If prefix is an access type, the node will be transformed into an
+ -- explicit dereference during expansion. The type of the node is the
+ -- designated type of that of the prefix.
if Is_Access_Type (Etype (P)) then
T := Designated_Type (Etype (P));
+ Check_Fully_Declared_Prefix (T, P);
else
T := Etype (P);
end if;
Apply_Access_Check (N);
Array_Type := Designated_Type (Array_Type);
- -- If the prefix is an access to an unconstrained array, we must
- -- use the actual subtype of the object to perform the index checks.
- -- The object denoted by the prefix is implicit in the node, so we
- -- build an explicit representation for it in order to compute the
- -- actual subtype.
+ -- If the prefix is an access to an unconstrained array, we must use
+ -- the actual subtype of the object to perform the index checks. The
+ -- object denoted by the prefix is implicit in the node, so we build
+ -- an explicit representation for it in order to compute the actual
+ -- subtype.
if not Is_Constrained (Array_Type) then
Remove_Side_Effects (Prefix (N));
Set_Etype (N, Array_Type);
- -- If the range is specified by a subtype mark, no resolution
- -- is necessary. Else resolve the bounds, and apply needed checks.
+ -- If the range is specified by a subtype mark, no resolution is
+ -- necessary. Else resolve the bounds, and apply needed checks.
if not Is_Entity_Name (Drange) then
Index := First_Index (Array_Type);
begin
-- For a string appearing in a concatenation, defer creation of the
-- string_literal_subtype until the end of the resolution of the
- -- concatenation, because the literal may be constant-folded away.
- -- This is a useful optimization for long concatenation expressions.
+ -- concatenation, because the literal may be constant-folded away. This
+ -- is a useful optimization for long concatenation expressions.
- -- If the string is an aggregate built for a single character (which
+ -- If the string is an aggregate built for a single character (which
-- happens in a non-static context) or a is null string to which special
- -- checks may apply, we build the subtype. Wide strings must also get
- -- a string subtype if they come from a one character aggregate. Strings
+ -- checks may apply, we build the subtype. Wide strings must also get a
+ -- string subtype if they come from a one character aggregate. Strings
-- generated by attributes might be static, but it is often hard to
-- determine whether the enclosing context is static, so we generate
-- subtypes for them as well, thus losing some rarer optimizations ???
if Strlen = 0 then
return;
- -- Always accept string literal with component type Any_Character,
- -- which occurs in error situations and in comparisons of literals,
- -- both of which should accept all literals.
+ -- Always accept string literal with component type Any_Character, which
+ -- occurs in error situations and in comparisons of literals, both of
+ -- which should accept all literals.
elsif R_Typ = Any_Character then
return;
- -- If the type is bit-packed, then we always tranform the string
- -- literal into a full fledged aggregate.
+ -- If the type is bit-packed, then we always tranform the string literal
+ -- into a full fledged aggregate.
elsif Is_Bit_Packed_Array (Typ) then
null;
if R_Typ = Standard_Wide_Wide_Character then
null;
- -- For the case of Standard.String, or any other type whose
- -- component type is Standard.Character, we must make sure that
- -- there are no wide characters in the string, i.e. that it is
- -- entirely composed of characters in range of type Character.
+ -- For the case of Standard.String, or any other type whose component
+ -- type is Standard.Character, we must make sure that there are no
+ -- wide characters in the string, i.e. that it is entirely composed
+ -- of characters in range of type Character.
- -- If the string literal is the result of a static concatenation,
- -- the test has already been performed on the components, and need
- -- not be repeated.
+ -- If the string literal is the result of a static concatenation, the
+ -- test has already been performed on the components, and need not be
+ -- repeated.
elsif R_Typ = Standard_Character
and then Nkind (Original_Node (N)) /= N_Op_Concat
null;
end if;
- -- See if the component type of the array corresponding to the
- -- string has compile time known bounds. If yes we can directly
- -- check whether the evaluation of the string will raise constraint
- -- error. Otherwise we need to transform the string literal into
- -- the corresponding character aggregate and let the aggregate
+ -- See if the component type of the array corresponding to the string
+ -- has compile time known bounds. If yes we can directly check
+ -- whether the evaluation of the string will raise constraint error.
+ -- Otherwise we need to transform the string literal into the
+ -- corresponding character aggregate and let the aggregate
-- code do the checking.
if R_Typ = Standard_Character
C : Char_Code;
begin
- -- Build the character literals, we give them source locations
- -- that correspond to the string positions, which is a bit tricky
- -- given the possible presence of wide character escape sequences.
+ -- Build the character literals, we give them source locations that
+ -- correspond to the string positions, which is a bit tricky given
+ -- the possible presence of wide character escape sequences.
for J in 1 .. Strlen loop
C := Get_String_Char (Str, J);
Opnd_Type := Etype (Opnd_Type);
end if;
+ -- Handle subtypes
+
+ if Ekind (Opnd_Type) = E_Protected_Subtype
+ or else Ekind (Opnd_Type) = E_Task_Subtype
+ then
+ Opnd_Type := Etype (Opnd_Type);
+ end if;
+
if not Interface_Present_In_Ancestor
(Typ => Opnd_Type,
Iface => Target_Type)
end if;
else
- -- If a conversion to an interface type appears as an actual
- -- in a source call, it will be expanded when the enclosing
- -- call itself is examined in Expand_Interface_Formals.
- -- Otherwise, generate the proper conversion code now, using
- -- the tag of the interface.
-
- if (Nkind (Parent (N)) = N_Procedure_Call_Statement
- or else Nkind (Parent (N)) = N_Function_Call)
- and then Comes_From_Source (N)
- then
- null;
- else
- Expand_Interface_Conversion (N);
- end if;
+ Expand_Interface_Conversion (N);
end if;
end;
end if;
--------------------------------
procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Low_Bound : constant Node_Id :=
+ Type_Low_Bound (Etype (First_Index (Typ)));
Subtype_Id : Entity_Id;
begin
if Nkind (N) /= N_String_Literal then
return;
- else
- Subtype_Id := Create_Itype (E_String_Literal_Subtype, N);
end if;
+ Subtype_Id := Create_Itype (E_String_Literal_Subtype, N);
Set_String_Literal_Length (Subtype_Id, UI_From_Int
(String_Length (Strval (N))));
- Set_Etype (Subtype_Id, Base_Type (Typ));
- Set_Is_Constrained (Subtype_Id);
+ Set_Etype (Subtype_Id, Base_Type (Typ));
+ Set_Is_Constrained (Subtype_Id);
+ Set_Etype (N, Subtype_Id);
+
+ if Is_OK_Static_Expression (Low_Bound) then
-- The low bound is set from the low bound of the corresponding
-- index type. Note that we do not store the high bound in the
- -- string literal subtype, but it can be deduced if necssary
+ -- string literal subtype, but it can be deduced if necessary
-- from the length and the low bound.
- Set_String_Literal_Low_Bound
- (Subtype_Id, Type_Low_Bound (Etype (First_Index (Typ))));
+ Set_String_Literal_Low_Bound (Subtype_Id, Low_Bound);
- Set_Etype (N, Subtype_Id);
+ else
+ Set_String_Literal_Low_Bound
+ (Subtype_Id, Make_Integer_Literal (Loc, 1));
+ Set_Etype (String_Literal_Low_Bound (Subtype_Id), Standard_Positive);
+
+ -- Build bona fide subtypes for the string, and wrap it in an
+ -- unchecked conversion, because the backend expects the
+ -- String_Literal_Subtype to have a static lower bound.
+
+ declare
+ Index_List : constant List_Id := New_List;
+ Index_Type : constant Entity_Id := Etype (First_Index (Typ));
+ High_Bound : constant Node_Id :=
+ Make_Op_Add (Loc,
+ Left_Opnd => New_Copy_Tree (Low_Bound),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ String_Length (Strval (N)) - 1));
+ Array_Subtype : Entity_Id;
+ Index_Subtype : Entity_Id;
+ Drange : Node_Id;
+ Index : Node_Id;
+
+ begin
+ Index_Subtype :=
+ Create_Itype (Subtype_Kind (Ekind (Index_Type)), N);
+ Drange := Make_Range (Loc, Low_Bound, High_Bound);
+ Set_Scalar_Range (Index_Subtype, Drange);
+ Set_Parent (Drange, N);
+ Analyze_And_Resolve (Drange, Index_Type);
+
+ Set_Etype (Index_Subtype, Index_Type);
+ Set_Size_Info (Index_Subtype, Index_Type);
+ Set_RM_Size (Index_Subtype, RM_Size (Index_Type));
+
+ Array_Subtype := Create_Itype (E_Array_Subtype, N);
+
+ Index := New_Occurrence_Of (Index_Subtype, Loc);
+ Set_Etype (Index, Index_Subtype);
+ Append (Index, Index_List);
+
+ Set_First_Index (Array_Subtype, Index);
+ Set_Etype (Array_Subtype, Base_Type (Typ));
+ Set_Is_Constrained (Array_Subtype, True);
+ Init_Size_Align (Array_Subtype);
+
+ Rewrite (N,
+ Make_Unchecked_Type_Conversion (Loc,
+ Subtype_Mark => New_Occurrence_Of (Array_Subtype, Loc),
+ Expression => Relocate_Node (N)));
+ Set_Etype (N, Array_Subtype);
+ end;
+ end if;
end Set_String_Literal_Subtype;
-----------------------------
Next_Index (Opnd_Index);
end loop;
- if Base_Type (Target_Comp_Type) /=
- Base_Type (Opnd_Comp_Type)
- then
- Error_Msg_N
- ("incompatible component types for array conversion",
- Operand);
- return False;
+ declare
+ BT : constant Entity_Id := Base_Type (Target_Comp_Type);
+ BO : constant Entity_Id := Base_Type (Opnd_Comp_Type);
- elsif
- Is_Constrained (Target_Comp_Type)
- /= Is_Constrained (Opnd_Comp_Type)
- or else not Subtypes_Statically_Match
- (Target_Comp_Type, Opnd_Comp_Type)
+ begin
+ if BT = BO then
+ null;
+
+ elsif
+ (Ekind (BT) = E_Anonymous_Access_Type
+ or else Ekind (BT) = E_Anonymous_Access_Subprogram_Type)
+ and then Ekind (BO) = Ekind (BT)
+ and then Subtypes_Statically_Match
+ (Target_Comp_Type, Opnd_Comp_Type)
+ then
+ null;
+
+ else
+ Error_Msg_N
+ ("incompatible component types for array conversion",
+ Operand);
+ return False;
+ end if;
+ end;
+
+ if Is_Constrained (Target_Comp_Type) /=
+ Is_Constrained (Opnd_Comp_Type)
+ or else not Subtypes_Statically_Match
+ (Target_Comp_Type, Opnd_Comp_Type)
then
Error_Msg_N
("component subtypes must statically match", Operand);
("?cannot convert local pointer to non-local access type",
Operand);
Error_Msg_N
- ("?Program_Error will be raised at run time", Operand);
-
+ ("\?Program_Error will be raised at run time", Operand);
else
Error_Msg_N
("cannot convert local pointer to non-local access type",
-- handles checking the prefix of the operand for this case.)
if Nkind (Operand) = N_Selected_Component
- and then Object_Access_Level (Operand)
- > Type_Access_Level (Target_Type)
+ and then Object_Access_Level (Operand) >
+ Type_Access_Level (Target_Type)
then
-- In an instance, this is a run-time check, but one we
-- know will fail, so generate an appropriate warning.
("?cannot convert access discriminant to non-local" &
" access type", Operand);
Error_Msg_N
- ("?Program_Error will be raised at run time", Operand);
-
+ ("\?Program_Error will be raised at run time", Operand);
else
Error_Msg_N
("cannot convert access discriminant to non-local" &
("?cannot convert local pointer to non-local access type",
Operand);
Error_Msg_N
- ("?Program_Error will be raised at run time", Operand);
+ ("\?Program_Error will be raised at run time", Operand);
else
Error_Msg_N
("?cannot convert access discriminant to non-local" &
" access type", Operand);
Error_Msg_N
- ("?Program_Error will be raised at run time", Operand);
+ ("\?Program_Error will be raised at run time",
+ Operand);
else
Error_Msg_N
projects / gcc.git / commitdiff