with Nmake; use Nmake;
with Output; use Output;
with Opt; use Opt;
-with Restrict; use Restrict;
+with Rtsfind; use Rtsfind;
with Scans; use Scans;
with Scn; use Scn;
with Sem; use Sem;
Rtyp := Typ;
end if;
- if No (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn))
- or else not Rep
- then
+ Discard_Node (
+ Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
+
+ if not Rep then
return;
end if;
Decl : Node_Id;
begin
+ -- Unchecked_Union components do not require component subtypes
+
+ if Is_Unchecked_Union (T) then
+ return Empty;
+ end if;
+
Subt :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('S'));
begin
if Ekind (T) = E_Incomplete_Type then
- -- Ada0Y (AI-50217): If the type is available through a limited
+ -- Ada 2005 (AI-50217): If the type is available through a limited
-- with_clause, verify that its full view has been analyzed.
if From_With_Type (T)
procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
S : Entity_Id;
- Loc : constant Source_Ptr := Sloc (N);
begin
- -- N is one of the potentially blocking operations listed in
- -- 9.5.1 (8). When using the Ravenscar profile, raise Program_Error
- -- before N if the context is a protected action. Otherwise, only issue
- -- a warning, since some users are relying on blocking operations
- -- inside protected objects.
- -- Indirect blocking through a subprogram call
- -- cannot be diagnosed statically without interprocedural analysis,
- -- so we do not attempt to do it here.
+ -- N is one of the potentially blocking operations listed in 9.5.1(8).
+ -- When pragma Detect_Blocking is active, the run time will raise
+ -- Program_Error. Here we only issue a warning, since we generally
+ -- support the use of potentially blocking operations in the absence
+ -- of the pragma.
- S := Scope (Current_Scope);
+ -- Indirect blocking through a subprogram call cannot be diagnosed
+ -- statically without interprocedural analysis, so we do not attempt
+ -- to do it here.
+ S := Scope (Current_Scope);
while Present (S) and then S /= Standard_Standard loop
if Is_Protected_Type (S) then
- if Restricted_Profile then
- Insert_Before_And_Analyze (N,
- Make_Raise_Program_Error (Loc,
- Reason => PE_Potentially_Blocking_Operation));
- Error_Msg_N ("potentially blocking operation, " &
- " Program Error will be raised at run time?", N);
-
- else
- Error_Msg_N
- ("potentially blocking operation in protected operation?", N);
- end if;
+ Error_Msg_N
+ ("potentially blocking operation in protected operation?", N);
return;
end if;
-- the body of an instance, constraint_checks are only warnings.
-- We also make this a warning if the Warn parameter is set.
- elsif Warn or else (Ada_83 and then Comes_From_Source (N)) then
+ elsif Warn
+ or else (Ada_Version = Ada_83 and then Comes_From_Source (N))
+ then
Msgl := Msgl + 1;
Msgc (Msgl) := '?';
Wmsg := True;
-- hides the implicit one, which is removed from all visibility,
-- i.e. the entity list of its scope, and homonym chain of its name.
- elsif (Is_Overloadable (E) and then Present (Alias (E)))
+ elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E))
or else Is_Internal (E)
- or else (Ekind (E) = E_Enumeration_Literal
- and then Is_Derived_Type (Etype (E)))
then
declare
Prev : Entity_Id;
C := First_Component (T);
while Present (C) loop
- if Is_Limited_Type (Etype (C)) then
+ if Is_Limited_Type (Etype (C))
+ and then Comes_From_Source (C)
+ then
Error_Msg_Node_2 := T;
Error_Msg_NE ("\component& of type& has limited type", N, C);
Explain_Limited_Type (Etype (C), N);
Next_Component (C);
end loop;
- -- It's odd if the loop falls through, but this is only an extra
- -- error message, so we just let it go and ignore the situation.
-
+ -- The type may be declared explicitly limited, even if no component
+ -- of it is limited, in which case we fall out of the loop.
return;
end if;
end Explain_Limited_Type;
-- because the discriminant is not available. The restrictions on
-- Unchecked_Union are designed to make sure that this is OK.
- elsif Is_Unchecked_Union (Utyp) then
+ elsif Is_Unchecked_Union (Base_Type (Utyp)) then
return Typ;
-- Here for the unconstrained case, we must find actual subtype
if Nkind (Decl) = N_Subprogram_Body then
return Decl;
+ -- The below comment is bad, because it is possible for
+ -- Nkind (Decl) to be an N_Subprogram_Body_Stub ???
+
else -- Nkind (Decl) = N_Subprogram_Declaration
if Present (Corresponding_Body (Decl)) then
return Unit_Declaration_Node (Corresponding_Body (Decl));
- else -- imported subprogram.
+ -- Imported subprogram case
+
+ else
return Empty;
end if;
end if;
return Task_Body_Procedure (Declaration_Node (Root_Type (E)));
end Get_Task_Body_Procedure;
+ -----------------------
+ -- Has_Access_Values --
+ -----------------------
+
+ function Has_Access_Values (T : Entity_Id) return Boolean is
+ Typ : constant Entity_Id := Underlying_Type (T);
+
+ begin
+ -- Case of a private type which is not completed yet. This can only
+ -- happen in the case of a generic format type appearing directly, or
+ -- as a component of the type to which this function is being applied
+ -- at the top level. Return False in this case, since we certainly do
+ -- not know that the type contains access types.
+
+ if No (Typ) then
+ return False;
+
+ elsif Is_Access_Type (Typ) then
+ return True;
+
+ elsif Is_Array_Type (Typ) then
+ return Has_Access_Values (Component_Type (Typ));
+
+ elsif Is_Record_Type (Typ) then
+ declare
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Entity (Typ);
+ while Present (Comp) loop
+ if (Ekind (Comp) = E_Component
+ or else
+ Ekind (Comp) = E_Discriminant)
+ and then Has_Access_Values (Etype (Comp))
+ then
+ return True;
+ end if;
+
+ Next_Entity (Comp);
+ end loop;
+ end;
+
+ return False;
+
+ else
+ return False;
+ end if;
+ end Has_Access_Values;
+
+ ----------------------
+ -- Has_Declarations --
+ ----------------------
+
+ function Has_Declarations (N : Node_Id) return Boolean is
+ K : constant Node_Kind := Nkind (N);
+ begin
+ return K = N_Accept_Statement
+ or else K = N_Block_Statement
+ or else K = N_Compilation_Unit_Aux
+ or else K = N_Entry_Body
+ or else K = N_Package_Body
+ or else K = N_Protected_Body
+ or else K = N_Subprogram_Body
+ or else K = N_Task_Body
+ or else K = N_Package_Specification;
+ end Has_Declarations;
+
--------------------
-- Has_Infinities --
--------------------
end if;
end Is_Aliased_View;
+ -------------------------
+ -- Is_Ancestor_Package --
+ -------------------------
+
+ function Is_Ancestor_Package
+ (E1 : Entity_Id;
+ E2 : Entity_Id) return Boolean
+ is
+ Par : Entity_Id;
+
+ begin
+ Par := E2;
+ while Present (Par)
+ and then Par /= Standard_Standard
+ loop
+ if Par = E1 then
+ return True;
+ end if;
+
+ Par := Scope (Par);
+ end loop;
+
+ return False;
+ end Is_Ancestor_Package;
+
----------------------
-- Is_Atomic_Object --
----------------------
P_Aliased := True;
end if;
+ -- A discriminant check on a selected component may be
+ -- expanded into a dereference when removing side-effects.
+ -- Recover the original node and its type, which may be
+ -- unconstrained.
+
+ elsif Nkind (P) = N_Explicit_Dereference
+ and then not (Comes_From_Source (P))
+ then
+ P := Original_Node (P);
+ Prefix_Type := Etype (P);
+
else
-- Check for prefix being an aliased component ???
null;
+
end if;
if Is_Access_Type (Prefix_Type)
then
return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
- elsif Nkind (Object) = N_Type_Conversion then
- -- A type conversion that Is_Variable is a view conversion:
- -- go back to the denoted object.
- return Is_Dependent_Component_Of_Mutable_Object
- (Expression (Object));
+ -- A type conversion that Is_Variable is a view conversion:
+ -- go back to the denoted object.
+ elsif Nkind (Object) = N_Type_Conversion then
+ return
+ Is_Dependent_Component_Of_Mutable_Object (Expression (Object));
end if;
end if;
and then Prefix (P) = N;
end Is_Dereferenced;
+ ----------------------
+ -- Is_Descendent_Of --
+ ----------------------
+
+ function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
+ T : Entity_Id;
+ Etyp : Entity_Id;
+
+ begin
+ pragma Assert (Nkind (T1) in N_Entity);
+ pragma Assert (Nkind (T2) in N_Entity);
+
+ T := Base_Type (T1);
+
+ -- Immediate return if the types match
+
+ if T = T2 then
+ return True;
+
+ -- Comment needed here ???
+
+ elsif Ekind (T) = E_Class_Wide_Type then
+ return Etype (T) = T2;
+
+ -- All other cases
+
+ else
+ loop
+ Etyp := Etype (T);
+
+ -- Done if we found the type we are looking for
+
+ if Etyp = T2 then
+ return True;
+
+ -- Done if no more derivations to check
+
+ elsif T = T1
+ or else T = Etyp
+ then
+ return False;
+
+ -- Following test catches error cases resulting from prev errors
+
+ elsif No (Etyp) then
+ return False;
+
+ elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
+ return False;
+
+ elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
+ return False;
+ end if;
+
+ T := Base_Type (Etyp);
+ end loop;
+ end if;
+
+ raise Program_Error;
+ end Is_Descendent_Of;
+
+ ------------------------------
+ -- Is_Descendent_Of_Address --
+ ------------------------------
+
+ function Is_Descendent_Of_Address (T1 : Entity_Id) return Boolean is
+ begin
+ -- If Address has not been loaded, answer must be False
+
+ if not RTU_Loaded (System) then
+ return False;
+
+ -- Otherwise we can get the entity we are interested in without
+ -- causing an unwanted dependency on System, and do the test.
+
+ else
+ return Is_Descendent_Of (T1, Base_Type (RTE (RE_Address)));
+ end if;
+ end Is_Descendent_Of_Address;
+
--------------
-- Is_False --
--------------
while Present (Discr) loop
if Nkind (Parent (Discr)) = N_Discriminant_Specification then
Discr_Val := Expression (Parent (Discr));
- if not Is_OK_Static_Expression (Discr_Val) then
- return False;
- else
+
+ if Present (Discr_Val)
+ and then Is_OK_Static_Expression (Discr_Val)
+ then
Append_To (Constraints,
Make_Component_Association (Loc,
Choices => New_List (New_Occurrence_Of (Discr, Loc)),
Expression => New_Copy (Discr_Val)));
-
+ else
+ return False;
end if;
else
return False;
return Attribute_Name (N) = Name_Input;
when N_Selected_Component =>
- return Is_Object_Reference (Selector_Name (N));
+ return
+ Is_Object_Reference (Selector_Name (N))
+ and then Is_Object_Reference (Prefix (N));
when N_Explicit_Dereference =>
return True;
then
return False;
+ elsif Nkind (Original_Node (AV)) = N_Type_Conversion then
+ return Is_OK_Variable_For_Out_Formal (Expression (AV));
+
else
return True;
end if;
procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
-- Clear current value for entity E and all entities chained to E
- -------------------------------------------
- -- Kill_Current_Values_For_Entity_Chain --
- -------------------------------------------
+ ------------------------------------------
+ -- Kill_Current_Values_For_Entity_Chain --
+ ------------------------------------------
procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
Ent : Entity_Id;
end if;
Formal := First_Formal (S);
-
while Present (Formal) loop
-- Match the formals in order. If the corresponding actual
or else
(Nkind (Parent (N)) = N_Function_Call
or else
- Nkind (Parent (N)) = N_Parameter_Association))
+ Nkind (Parent (N)) = N_Parameter_Association))
+ and then Ekind (S) /= E_Function
then
Set_Etype (N, Etype (S));
else
Actual := First (Actuals);
while Present (Actual) loop
-
if Nkind (Actual) = N_Parameter_Association
and then Actual /= Last
and then No (Next_Named_Actual (Actual))
--------------------------------
procedure Note_Possible_Modification (N : Node_Id) is
+ Modification_Comes_From_Source : constant Boolean :=
+ Comes_From_Source (Parent (N));
+
Ent : Entity_Id;
Exp : Node_Id;
- procedure Set_Ref (E : Entity_Id; N : Node_Id);
- -- Internal routine to note modification on entity E by node N
- -- Has no effect if entity E does not represent an object.
-
- -------------
- -- Set_Ref --
- -------------
-
- procedure Set_Ref (E : Entity_Id; N : Node_Id) is
- begin
- if Is_Object (E) then
- if Comes_From_Source (N) then
- Set_Never_Set_In_Source (E, False);
- end if;
-
- Set_Is_True_Constant (E, False);
- Set_Current_Value (E, Empty);
- Generate_Reference (E, N, 'm');
- Kill_Checks (E);
-
- if not Can_Never_Be_Null (E) then
- Set_Is_Known_Non_Null (E, False);
- end if;
- end if;
- end Set_Ref;
-
- -- Start of processing for Note_Possible_Modification
-
begin
-- Loop to find referenced entity, if there is one
Exp := N;
loop
- -- Test for node rewritten as dereference (e.g. accept parameter)
-
- if Nkind (Exp) = N_Explicit_Dereference
- and then not Comes_From_Source (Exp)
- then
- Exp := Original_Node (Exp);
- end if;
-
- -- Now look for entity being referenced
+ <<Continue>>
+ Ent := Empty;
if Is_Entity_Name (Exp) then
Ent := Entity (Exp);
- if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
- and then Present (Renamed_Object (Ent))
- then
- Set_Never_Set_In_Source (Ent, False);
- Set_Is_True_Constant (Ent, False);
- Set_Current_Value (Ent, Empty);
+ elsif Nkind (Exp) = N_Explicit_Dereference then
+ declare
+ P : constant Node_Id := Prefix (Exp);
- if not Can_Never_Be_Null (Ent) then
- Set_Is_Known_Non_Null (Ent, False);
- end if;
+ begin
+ if Nkind (P) = N_Selected_Component
+ and then Present (
+ Entry_Formal (Entity (Selector_Name (P))))
+ then
+ -- Case of a reference to an entry formal
- Exp := Renamed_Object (Ent);
+ Ent := Entry_Formal (Entity (Selector_Name (P)));
- else
- Set_Ref (Ent, Exp);
- Kill_Checks (Ent);
- return;
- end if;
+ elsif Nkind (P) = N_Identifier
+ and then Nkind (Parent (Entity (P))) = N_Object_Declaration
+ and then Present (Expression (Parent (Entity (P))))
+ and then Nkind (Expression (Parent (Entity (P))))
+ = N_Reference
+ then
+ -- Case of a reference to a value on which
+ -- side effects have been removed.
+
+ Exp := Prefix (Expression (Parent (Entity (P))));
+
+ else
+ return;
+
+ end if;
+ end;
elsif Nkind (Exp) = N_Type_Conversion
or else Nkind (Exp) = N_Unchecked_Type_Conversion
else
return;
+
+ end if;
+
+ -- Now look for entity being referenced
+
+ if Present (Ent) then
+
+ if Is_Object (Ent) then
+ if Comes_From_Source (Exp)
+ or else Modification_Comes_From_Source
+ then
+ Set_Never_Set_In_Source (Ent, False);
+ end if;
+
+ Set_Is_True_Constant (Ent, False);
+ Set_Current_Value (Ent, Empty);
+
+ if not Can_Never_Be_Null (Ent) then
+ Set_Is_Known_Non_Null (Ent, False);
+ end if;
+
+ if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
+ and then Present (Renamed_Object (Ent))
+ then
+ Exp := Renamed_Object (Ent);
+ goto Continue;
+ end if;
+
+ Generate_Reference (Ent, Exp, 'm');
+ end if;
+
+ Kill_Checks (Ent);
+ return;
end if;
end loop;
end Note_Possible_Modification;
if Is_Private_Type (Btype)
and then not Is_Generic_Type (Btype)
then
- return Btype;
+ if Present (Full_View (Btype))
+ and then Is_Record_Type (Full_View (Btype))
+ and then not Is_Frozen (Btype)
+ then
+ -- To indicate that the ancestor depends on a private type,
+ -- the current Btype is sufficient. However, to check for
+ -- circular definition we must recurse on the full view.
+
+ Candidate := Trace_Components (Full_View (Btype), True);
+
+ if Candidate = Any_Type then
+ return Any_Type;
+ else
+ return Btype;
+ end if;
+
+ else
+ return Btype;
+ end if;
elsif Is_Array_Type (Btype) then
return Trace_Components (Component_Type (Btype), True);
function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
begin
- if Range_Checks_Suppressed (E) then
- return New_Occurrence_Of (Standard_False, Loc);
- else
- return New_Occurrence_Of (Standard_True, Loc);
- end if;
+ return New_Occurrence_Of
+ (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc);
end Rep_To_Pos_Flag;
--------------------
-- A transient scope is required when variable-sized temporaries are
-- allocated in the primary or secondary stack, or when finalization
- -- actions must be generated before the next instruction
+ -- actions must be generated before the next instruction.
function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
Typ : constant Entity_Id := Underlying_Type (Id);
+ -- Start of processing for Requires_Transient_Scope
+
begin
-- This is a private type which is not completed yet. This can only
-- happen in a default expression (of a formal parameter or of a
if No (Typ) then
return False;
+ -- Do not expand transient scope for non-existent procedure return
+
elsif Typ = Standard_Void_Type then
return False;
- -- The back-end has trouble allocating variable-size temporaries so
- -- we generate them in the front-end and need a transient scope to
- -- reclaim them properly
+ -- Elementary types do not require a transient scope
- elsif not Size_Known_At_Compile_Time (Typ) then
- return True;
+ elsif Is_Elementary_Type (Typ) then
+ return False;
- -- Unconstrained discriminated records always require a variable
- -- length temporary, since the length may depend on the variant.
+ -- Generally, indefinite subtypes require a transient scope, since the
+ -- back end cannot generate temporaries, since this is not a valid type
+ -- for declaring an object. It might be possible to relax this in the
+ -- future, e.g. by declaring the maximum possible space for the type.
- elsif Is_Record_Type (Typ)
- and then Has_Discriminants (Typ)
- and then not Is_Constrained (Typ)
- then
+ elsif Is_Indefinite_Subtype (Typ) then
return True;
-- Functions returning tagged types may dispatch on result so their
then
return True;
- -- Unconstrained array types are returned on the secondary stack
+ -- Record type
+
+ elsif Is_Record_Type (Typ) then
+
+ -- In GCC 2, discriminated records always require a transient
+ -- scope because the back end otherwise tries to allocate a
+ -- variable length temporary for the particular variant.
+
+ if Opt.GCC_Version = 2
+ and then Has_Discriminants (Typ)
+ then
+ return True;
+
+ -- For GCC 3, or for a non-discriminated record in GCC 2, we are
+ -- OK if none of the component types requires a transient scope.
+ -- Note that we already know that this is a definite type (i.e.
+ -- has discriminant defaults if it is a discriminated record).
+
+ else
+ declare
+ Comp : Entity_Id;
+ begin
+ Comp := First_Entity (Typ);
+ while Present (Comp) loop
+ if Requires_Transient_Scope (Etype (Comp)) then
+ return True;
+ else
+ Next_Entity (Comp);
+ end if;
+ end loop;
+ end;
+
+ return False;
+ end if;
+
+ -- String literal types never require transient scope
+
+ elsif Ekind (Typ) = E_String_Literal_Subtype then
+ return False;
+
+ -- Array type. Note that we already know that this is a constrained
+ -- array, since unconstrained arrays will fail the indefinite test.
elsif Is_Array_Type (Typ) then
- return not Is_Constrained (Typ);
- end if;
- return False;
+ -- If component type requires a transient scope, the array does too
+
+ if Requires_Transient_Scope (Component_Type (Typ)) then
+ return True;
+
+ -- Otherwise, we only need a transient scope if the size is not
+ -- known at compile time.
+
+ else
+ return not Size_Known_At_Compile_Time (Typ);
+ end if;
+
+ -- All other cases do not require a transient scope
+
+ else
+ return False;
+ end if;
end Requires_Transient_Scope;
--------------------------
-- declared at the library level to ensure that names such as
-- X.all'access don't fail static accessibility checks.
+ -- Ada 2005 (AI-230): In case of anonymous access types that are
+ -- component_definition or discriminants of a nonlimited type,
+ -- the level is the same as that of the enclosing component type.
+
Btyp := Base_Type (Typ);
if Ekind (Btyp) in Access_Kind then
- if Ekind (Btyp) = E_Anonymous_Access_Type then
+ if Ekind (Btyp) = E_Anonymous_Access_Type
+ and then not Is_Array_Type (Scope (Btyp)) -- Ada 2005 (AI-230)
+ and then Ekind (Scope (Btyp)) /= E_Record_Type -- Ada 2005 (AI-230)
+ then
return Scope_Depth (Standard_Standard);
end if;
("found function name, possibly missing Access attribute!",
Expr);
- -- catch common error: a prefix or infix operator which is not
+ -- Catch common error: a prefix or infix operator which is not
-- directly visible because the type isn't.
elsif Nkind (Expr) in N_Op
OSDN Git Service
