------------------------------------------------------------------------------
+------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- --
-- B o d y --
-- --
--- $Revision$
--- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, 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- --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Casing; use Casing;
+with Checks; use Checks;
with Debug; use Debug;
with Errout; use Errout;
with Elists; use Elists;
+with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
+with Fname; use Fname;
with Freeze; use Freeze;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
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;
-----------------------
function Build_Component_Subtype
- (C : List_Id;
- Loc : Source_Ptr;
- T : Entity_Id)
- return Node_Id;
+ (C : List_Id;
+ Loc : Source_Ptr;
+ T : Entity_Id) return Node_Id;
-- This function builds the subtype for Build_Actual_Subtype_Of_Component
-- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
-- Loc is the source location, T is the original subtype.
+ function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean;
+ -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
+ -- with discriminants whose default values are static, examine only the
+ -- components in the selected variant to determine whether all of them
+ -- have a default.
+
+ function Has_Null_Extension (T : Entity_Id) return Boolean;
+ -- T is a derived tagged type. Check whether the type extension is null.
+ -- If the parent type is fully initialized, T can be treated as such.
+
--------------------------------
-- Add_Access_Type_To_Process --
--------------------------------
- procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id)
- is
+ procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is
L : Elist_Id;
+
begin
Ensure_Freeze_Node (E);
L := Access_Types_To_Process (Freeze_Node (E));
-----------------------------------------
procedure Apply_Compile_Time_Constraint_Error
- (N : Node_Id;
- Msg : String;
- Ent : Entity_Id := Empty;
- Typ : Entity_Id := Empty;
- Loc : Source_Ptr := No_Location;
- Rep : Boolean := True)
+ (N : Node_Id;
+ Msg : String;
+ Reason : RT_Exception_Code;
+ Ent : Entity_Id := Empty;
+ Typ : Entity_Id := Empty;
+ Loc : Source_Ptr := No_Location;
+ Rep : Boolean := True;
+ Warn : Boolean := False)
is
Stat : constant Boolean := Is_Static_Expression (N);
Rtyp : Entity_Id;
Rtyp := Typ;
end if;
- if No (Compile_Time_Constraint_Error (N, Msg, Ent, Loc))
- or else not Rep
- then
+ Discard_Node (
+ Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
+
+ if not Rep then
return;
end if;
-- Now we replace the node by an N_Raise_Constraint_Error node
-- This does not need reanalyzing, so set it as analyzed now.
- Rewrite (N, Make_Raise_Constraint_Error (Sloc (N)));
+ Rewrite (N,
+ Make_Raise_Constraint_Error (Sloc (N),
+ Reason => Reason));
Set_Analyzed (N, True);
Set_Etype (N, Rtyp);
Set_Raises_Constraint_Error (N);
--------------------------
function Build_Actual_Subtype
- (T : Entity_Id;
- N : Node_Or_Entity_Id)
- return Node_Id
+ (T : Entity_Id;
+ N : Node_Or_Entity_Id) return Node_Id
is
Obj : Node_Id;
-- Build an array subtype declaration with the nominal
-- subtype and the bounds of the actual. Add the declaration
- -- in front of the local declarations for the subprogram,for
+ -- in front of the local declarations for the subprogram, for
-- analysis before any reference to the formal in the body.
Lo :=
Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (Obj, Name_Req => True),
+ Prefix =>
+ Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
Attribute_Name => Name_First,
Expressions => New_List (
Make_Integer_Literal (Loc, J)));
Hi :=
Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (Obj, Name_Req => True),
+ Prefix =>
+ Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
Attribute_Name => Name_Last,
Expressions => New_List (
Make_Integer_Literal (Loc, J)));
end loop;
-- If the type has unknown discriminants there is no constrained
- -- subtype to build.
+ -- subtype to build. This is never called for a formal or for a
+ -- lhs, so returning the type is ok ???
elsif Has_Unknown_Discriminants (T) then
return T;
while Present (Discr) loop
Append_To (Constraints,
Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (Obj),
+ Prefix =>
+ Duplicate_Subexpr_No_Checks (Obj),
Selector_Name => New_Occurrence_Of (Discr, Loc)));
Next_Discriminant (Discr);
end loop;
---------------------------------------
function Build_Actual_Subtype_Of_Component
- (T : Entity_Id;
- N : Node_Id)
- return Node_Id
+ (T : Entity_Id;
+ N : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
P : constant Node_Id := Prefix (N);
-----------------------------------
function Build_Actual_Array_Constraint return List_Id is
- Constraints : List_Id := New_List;
+ Constraints : constant List_Id := New_List;
Indx : Node_Id;
Hi : Node_Id;
Lo : Node_Id;
------------------------------------
function Build_Actual_Record_Constraint return List_Id is
- Constraints : List_Id := New_List;
+ Constraints : constant List_Id := New_List;
D : Elmt_Id;
D_Val : Node_Id;
-- Start of processing for Build_Actual_Subtype_Of_Component
begin
- if Nkind (N) = N_Explicit_Dereference then
+ if In_Default_Expression then
+ return Empty;
+
+ elsif Nkind (N) = N_Explicit_Dereference then
if Is_Composite_Type (T)
and then not Is_Constrained (T)
and then not (Is_Class_Wide_Type (T)
end if;
if Ekind (Deaccessed_T) = E_Array_Subtype then
-
Id := First_Index (Deaccessed_T);
Indx_Type := Underlying_Type (Etype (Id));
-- If none of the above, the actual and nominal subtypes are the same.
return Empty;
-
end Build_Actual_Subtype_Of_Component;
-----------------------------
-----------------------------
function Build_Component_Subtype
- (C : List_Id;
- Loc : Source_Ptr;
- T : Entity_Id)
- return Node_Id
+ (C : List_Id;
+ Loc : Source_Ptr;
+ T : Entity_Id) return Node_Id
is
Subt : Entity_Id;
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'));
--------------------------------------------
function Build_Discriminal_Subtype_Of_Component
- (T : Entity_Id)
- return Node_Id
+ (T : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (T);
D : Elmt_Id;
----------------------------------------
function Build_Discriminal_Array_Constraint return List_Id is
- Constraints : List_Id := New_List;
+ Constraints : constant List_Id := New_List;
Indx : Node_Id;
Hi : Node_Id;
Lo : Node_Id;
-----------------------------------------
function Build_Discriminal_Record_Constraint return List_Id is
- Constraints : List_Id := New_List;
- D : Elmt_Id;
- D_Val : Node_Id;
+ Constraints : constant List_Id := New_List;
+ D : Elmt_Id;
+ D_Val : Node_Id;
begin
D := First_Elmt (Discriminant_Constraint (T));
while Present (D) loop
-
if Denotes_Discriminant (Node (D)) then
D_Val :=
New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
begin
if Ekind (T) = E_Array_Subtype then
-
Id := First_Index (T);
while Present (Id) loop
-
if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) or else
Denotes_Discriminant (Type_High_Bound (Etype (Id)))
then
then
D := First_Elmt (Discriminant_Constraint (T));
while Present (D) loop
-
if Denotes_Discriminant (Node (D)) then
return Build_Component_Subtype
(Build_Discriminal_Record_Constraint, Loc, T);
-- If none of the above, the actual and nominal subtypes are the same.
return Empty;
-
end Build_Discriminal_Subtype_Of_Component;
------------------------------
-- assign a value to the variable in the binder main.
Set_Is_True_Constant (Elab_Ent, False);
+ Set_Current_Value (Elab_Ent, Empty);
-- We do not want any further qualification of the name (if we did
-- not do this, we would pick up the name of the generic package
Set_Has_Fully_Qualified_Name (Elab_Ent);
end Build_Elaboration_Entity;
+ -----------------------------------
+ -- Cannot_Raise_Constraint_Error --
+ -----------------------------------
+
+ function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is
+ begin
+ if Compile_Time_Known_Value (Expr) then
+ return True;
+
+ elsif Do_Range_Check (Expr) then
+ return False;
+
+ elsif Raises_Constraint_Error (Expr) then
+ return False;
+
+ else
+ case Nkind (Expr) is
+ when N_Identifier =>
+ return True;
+
+ when N_Expanded_Name =>
+ return True;
+
+ when N_Selected_Component =>
+ return not Do_Discriminant_Check (Expr);
+
+ when N_Attribute_Reference =>
+ if Do_Overflow_Check (Expr) then
+ return False;
+
+ elsif No (Expressions (Expr)) then
+ return True;
+
+ else
+ declare
+ N : Node_Id := First (Expressions (Expr));
+
+ begin
+ while Present (N) loop
+ if Cannot_Raise_Constraint_Error (N) then
+ Next (N);
+ else
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end;
+ end if;
+
+ when N_Type_Conversion =>
+ if Do_Overflow_Check (Expr)
+ or else Do_Length_Check (Expr)
+ or else Do_Tag_Check (Expr)
+ then
+ return False;
+ else
+ return
+ Cannot_Raise_Constraint_Error (Expression (Expr));
+ end if;
+
+ when N_Unchecked_Type_Conversion =>
+ return Cannot_Raise_Constraint_Error (Expression (Expr));
+
+ when N_Unary_Op =>
+ if Do_Overflow_Check (Expr) then
+ return False;
+ else
+ return
+ Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
+ end if;
+
+ when N_Op_Divide |
+ N_Op_Mod |
+ N_Op_Rem
+ =>
+ if Do_Division_Check (Expr)
+ or else Do_Overflow_Check (Expr)
+ then
+ return False;
+ else
+ return
+ Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
+ and then
+ Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
+ end if;
+
+ when N_Op_Add |
+ N_Op_And |
+ N_Op_Concat |
+ N_Op_Eq |
+ N_Op_Expon |
+ N_Op_Ge |
+ N_Op_Gt |
+ N_Op_Le |
+ N_Op_Lt |
+ N_Op_Multiply |
+ N_Op_Ne |
+ N_Op_Or |
+ N_Op_Rotate_Left |
+ N_Op_Rotate_Right |
+ N_Op_Shift_Left |
+ N_Op_Shift_Right |
+ N_Op_Shift_Right_Arithmetic |
+ N_Op_Subtract |
+ N_Op_Xor
+ =>
+ if Do_Overflow_Check (Expr) then
+ return False;
+ else
+ return
+ Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
+ and then
+ Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
+ end if;
+
+ when others =>
+ return False;
+ end case;
+ end if;
+ end Cannot_Raise_Constraint_Error;
+
--------------------------
-- Check_Fully_Declared --
--------------------------
procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
begin
if Ekind (T) = E_Incomplete_Type then
- Error_Msg_NE
- ("premature usage of incomplete}", N, First_Subtype (T));
+
+ -- 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)
+ and then Present (Non_Limited_View (T))
+ and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
+ then
+ -- The non-limited view is fully declared
+ null;
+
+ else
+ Error_Msg_NE
+ ("premature usage of incomplete}", N, First_Subtype (T));
+ end if;
elsif Has_Private_Component (T)
and then not Is_Generic_Type (Root_Type (T))
and then not In_Default_Expression
then
- Error_Msg_NE
- ("premature usage of incomplete}", N, First_Subtype (T));
+
+ -- Special case: if T is the anonymous type created for a single
+ -- task or protected object, use the name of the source object.
+
+ if Is_Concurrent_Type (T)
+ and then not Comes_From_Source (T)
+ and then Nkind (N) = N_Object_Declaration
+ then
+ Error_Msg_NE ("type of& has incomplete component", N,
+ Defining_Identifier (N));
+
+ else
+ Error_Msg_NE
+ ("premature usage of incomplete}", N, First_Subtype (T));
+ end if;
end if;
end Check_Fully_Declared;
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 (N,
- Make_Raise_Statement (Loc,
- Name => New_Occurrence_Of (Standard_Program_Error, Loc)));
- 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;
B_Scope := System_Aux_Id;
Id := First_Entity (System_Aux_Id);
end if;
-
end loop;
-
end if;
return Op_List;
(N : Node_Id;
Msg : String;
Ent : Entity_Id := Empty;
- Loc : Source_Ptr := No_Location)
- return Node_Id
+ Loc : Source_Ptr := No_Location;
+ Warn : Boolean := False) return Node_Id
is
Msgc : String (1 .. Msg'Length + 2);
Msgl : Natural;
- Warn : Boolean;
+ Wmsg : Boolean;
P : Node_Id;
Msgs : Boolean;
+ Eloc : Source_Ptr;
begin
-- A static constraint error in an instance body is not a fatal error.
-- No messages are generated if we already posted an error on this node
if not Error_Posted (N) then
+ if Loc /= No_Location then
+ Eloc := Loc;
+ else
+ Eloc := Sloc (N);
+ end if;
-- Make all such messages unconditional
-- Message is a warning, even in Ada 95 case
if Msg (Msg'Length) = '?' then
- Warn := True;
+ Wmsg := True;
-- In Ada 83, all messages are warnings. In the private part and
-- the body of an instance, constraint_checks are only warnings.
+ -- We also make this a warning if the Warn parameter is set.
- elsif 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) := '?';
- Warn := True;
+ Wmsg := True;
elsif In_Instance_Not_Visible then
-
Msgl := Msgl + 1;
Msgc (Msgl) := '?';
- Warn := True;
- Warn_On_Instance := True;
+ Wmsg := True;
-- Otherwise we have a real error message (Ada 95 static case)
else
- Warn := False;
+ Wmsg := False;
end if;
-- Should we generate a warning? The answer is not quite yes. The
if Msgs then
if Present (Ent) then
- Error_Msg_NE (Msgc (1 .. Msgl), N, Ent);
+ Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc);
else
- Error_Msg_NE (Msgc (1 .. Msgl), N, Etype (N));
+ Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc);
end if;
- if Warn then
+ if Wmsg then
if Inside_Init_Proc then
- Error_Msg_NE
+ Error_Msg_NEL
("\& will be raised for objects of this type!?",
- N, Standard_Constraint_Error);
+ N, Standard_Constraint_Error, Eloc);
else
- Error_Msg_NE
+ Error_Msg_NEL
("\& will be raised at run time!?",
- N, Standard_Constraint_Error);
+ N, Standard_Constraint_Error, Eloc);
end if;
else
- Error_Msg_NE
+ Error_Msg_NEL
("\static expression raises&!",
- N, Standard_Constraint_Error);
+ N, Standard_Constraint_Error, Eloc);
end if;
end if;
end if;
Scop : constant Entity_Id := Current_Scope;
begin
- if Ekind (Scop) = E_Function
- or else
- Ekind (Scop) = E_Procedure
- or else
- Ekind (Scop) = E_Generic_Function
- or else
- Ekind (Scop) = E_Generic_Procedure
- then
+ if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then
return Scop;
-
else
return Enclosing_Subprogram (Scop);
end if;
---------------------
function Defining_Entity (N : Node_Id) return Entity_Id is
- K : constant Node_Kind := Nkind (N);
+ K : constant Node_Kind := Nkind (N);
+ Err : Entity_Id := Empty;
begin
case K is
begin
if Nkind (Nam) in N_Entity then
return Nam;
+
+ -- For Error, make up a name and attach to declaration
+ -- so we can continue semantic analysis
+
+ elsif Nam = Error then
+ Err :=
+ Make_Defining_Identifier (Sloc (N),
+ Chars => New_Internal_Name ('T'));
+ Set_Defining_Unit_Name (N, Err);
+
+ return Err;
+ -- If not an entity, get defining identifier
+
else
return Defining_Identifier (Nam);
end if;
-- Denotes_Discriminant --
--------------------------
- function Denotes_Discriminant (N : Node_Id) return Boolean is
+ function Denotes_Discriminant
+ (N : Node_Id;
+ Check_Protected : Boolean := False) return Boolean
+ is
+ E : Entity_Id;
begin
- return Is_Entity_Name (N)
- and then Present (Entity (N))
- and then Ekind (Entity (N)) = E_Discriminant;
+ if not Is_Entity_Name (N)
+ or else No (Entity (N))
+ then
+ return False;
+ else
+ E := Entity (N);
+ end if;
+
+ -- If we are checking for a protected type, the discriminant may have
+ -- been rewritten as the corresponding discriminal of the original type
+ -- or of the corresponding concurrent record, depending on whether we
+ -- are in the spec or body of the protected type.
+
+ return Ekind (E) = E_Discriminant
+ or else
+ (Check_Protected
+ and then Ekind (E) = E_In_Parameter
+ and then Present (Discriminal_Link (E))
+ and then
+ (Is_Protected_Type (Scope (Discriminal_Link (E)))
+ or else
+ Is_Concurrent_Record_Type (Scope (Discriminal_Link (E)))));
+
end Denotes_Discriminant;
-----------------------------
function Designate_Same_Unit
(Name1 : Node_Id;
- Name2 : Node_Id)
- return Boolean
+ Name2 : Node_Id) return Boolean
is
- K1 : Node_Kind := Nkind (Name1);
- K2 : Node_Kind := Nkind (Name2);
+ K1 : constant Node_Kind := Nkind (Name1);
+ K2 : constant Node_Kind := Nkind (Name2);
function Prefix_Node (N : Node_Id) return Node_Id;
-- Returns the parent unit name node of a defining program unit name
-- name or the selector node if N is a selected component or an
-- expanded name.
+ -----------------
+ -- Prefix_Node --
+ -----------------
+
function Prefix_Node (N : Node_Id) return Node_Id is
begin
if Nkind (N) = N_Defining_Program_Unit_Name then
end if;
end Prefix_Node;
+ -----------------
+ -- Select_Node --
+ -----------------
+
function Select_Node (N : Node_Id) return Node_Id is
begin
if Nkind (N) = N_Defining_Program_Unit_Name then
----------------------------
function Enclosing_Generic_Body
- (E : Entity_Id)
- return Node_Id
+ (E : Entity_Id) return Node_Id
is
P : Node_Id;
Decl : Node_Id;
-- 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;
Prev_Vis : Entity_Id;
+ Decl : constant Node_Id := Parent (E);
begin
-- If E is an implicit declaration, it cannot be the first
Prev := First_Entity (Current_Scope);
- while Next_Entity (Prev) /= E loop
+ while Present (Prev)
+ and then Next_Entity (Prev) /= E
+ loop
Next_Entity (Prev);
end loop;
- Set_Next_Entity (Prev, Next_Entity (E));
+ if No (Prev) then
- if No (Next_Entity (Prev)) then
- Set_Last_Entity (Current_Scope, Prev);
- end if;
+ -- If E is not on the entity chain of the current scope,
+ -- it is an implicit declaration in the generic formal
+ -- part of a generic subprogram. When analyzing the body,
+ -- the generic formals are visible but not on the entity
+ -- chain of the subprogram. The new entity will become
+ -- the visible one in the body.
+
+ pragma Assert
+ (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration);
+ null;
- if E = Current_Entity (E) then
- Prev_Vis := Empty;
else
- Prev_Vis := Current_Entity (E);
- while Homonym (Prev_Vis) /= E loop
- Prev_Vis := Homonym (Prev_Vis);
- end loop;
- end if;
+ Set_Next_Entity (Prev, Next_Entity (E));
+
+ if No (Next_Entity (Prev)) then
+ Set_Last_Entity (Current_Scope, Prev);
+ end if;
+
+ if E = Current_Entity (E) then
+ Prev_Vis := Empty;
- if Present (Prev_Vis) then
+ else
+ Prev_Vis := Current_Entity (E);
+ while Homonym (Prev_Vis) /= E loop
+ Prev_Vis := Homonym (Prev_Vis);
+ end loop;
+ end if;
- -- Skip E in the visibility chain
+ if Present (Prev_Vis) then
- Set_Homonym (Prev_Vis, Homonym (E));
+ -- Skip E in the visibility chain
- else
- Set_Name_Entity_Id (Chars (E), Homonym (E));
+ Set_Homonym (Prev_Vis, Homonym (E));
+
+ else
+ Set_Name_Entity_Id (Chars (E), Homonym (E));
+ end if;
end if;
end;
Error_Msg_N ("& conflicts with declaration#", E);
return;
+ -- If the name of the unit appears in its own context clause,
+ -- a dummy package with the name has already been created, and
+ -- the error emitted. Try to continue quietly.
+
+ elsif Error_Posted (E)
+ and then Sloc (E) = No_Location
+ and then Nkind (Parent (E)) = N_Package_Specification
+ and then Current_Scope = Standard_Standard
+ then
+ Set_Scope (Def_Id, Current_Scope);
+ return;
+
else
Error_Msg_N ("& conflicts with declaration#", Def_Id);
-- Warn if new entity hides an old one
if Warn_On_Hiding
- and then Length_Of_Name (Chars (C)) /= 1
and then Present (C)
+ and then Length_Of_Name (Chars (C)) /= 1
and then Comes_From_Source (C)
and then Comes_From_Source (Def_Id)
and then In_Extended_Main_Source_Unit (Def_Id)
Error_Msg_Sloc := Sloc (C);
Error_Msg_N ("declaration hides &#?", Def_Id);
end if;
-
end Enter_Name;
+ --------------------------
+ -- Explain_Limited_Type --
+ --------------------------
+
+ procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is
+ C : Entity_Id;
+
+ begin
+ -- For array, component type must be limited
+
+ if Is_Array_Type (T) then
+ Error_Msg_Node_2 := T;
+ Error_Msg_NE
+ ("component type& of type& is limited", N, Component_Type (T));
+ Explain_Limited_Type (Component_Type (T), N);
+
+ elsif Is_Record_Type (T) then
+
+ -- No need for extra messages if explicit limited record
+
+ if Is_Limited_Record (Base_Type (T)) then
+ return;
+ end if;
+
+ -- Otherwise find a limited component
+
+ C := First_Component (T);
+ while Present (C) loop
+ 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);
+ return;
+ end if;
+
+ Next_Component (C);
+ end loop;
+
+ -- 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;
+
-------------------------------------
-- Find_Corresponding_Discriminant --
-------------------------------------
function Find_Corresponding_Discriminant
- (Id : Node_Id;
- Typ : Entity_Id)
- return Entity_Id
+ (Id : Node_Id;
+ Typ : Entity_Id) return Entity_Id
is
Par_Disc : Entity_Id;
Old_Disc : Entity_Id;
begin
Par_Disc := Original_Record_Component (Original_Discriminant (Id));
- Old_Disc := First_Discriminant (Scope (Par_Disc));
+
+ -- The original type may currently be private, and the discriminant
+ -- only appear on its full view.
+
+ if Is_Private_Type (Scope (Par_Disc))
+ and then not Has_Discriminants (Scope (Par_Disc))
+ and then Present (Full_View (Scope (Par_Disc)))
+ then
+ Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc)));
+ else
+ Old_Disc := First_Discriminant (Scope (Par_Disc));
+ end if;
if Is_Class_Wide_Type (Typ) then
New_Disc := First_Discriminant (Root_Type (Typ));
raise Program_Error;
end Find_Corresponding_Discriminant;
+ -----------------------------
+ -- Find_Static_Alternative --
+ -----------------------------
+
+ function Find_Static_Alternative (N : Node_Id) return Node_Id is
+ Expr : constant Node_Id := Expression (N);
+ Val : constant Uint := Expr_Value (Expr);
+ Alt : Node_Id;
+ Choice : Node_Id;
+
+ begin
+ Alt := First (Alternatives (N));
+
+ Search : loop
+ if Nkind (Alt) /= N_Pragma then
+ Choice := First (Discrete_Choices (Alt));
+
+ while Present (Choice) loop
+
+ -- Others choice, always matches
+
+ if Nkind (Choice) = N_Others_Choice then
+ exit Search;
+
+ -- Range, check if value is in the range
+
+ elsif Nkind (Choice) = N_Range then
+ exit Search when
+ Val >= Expr_Value (Low_Bound (Choice))
+ and then
+ Val <= Expr_Value (High_Bound (Choice));
+
+ -- Choice is a subtype name. Note that we know it must
+ -- be a static subtype, since otherwise it would have
+ -- been diagnosed as illegal.
+
+ elsif Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice))
+ then
+ exit Search when Is_In_Range (Expr, Etype (Choice));
+
+ -- Choice is a subtype indication
+
+ elsif Nkind (Choice) = N_Subtype_Indication then
+ declare
+ C : constant Node_Id := Constraint (Choice);
+ R : constant Node_Id := Range_Expression (C);
+
+ begin
+ exit Search when
+ Val >= Expr_Value (Low_Bound (R))
+ and then
+ Val <= Expr_Value (High_Bound (R));
+ end;
+
+ -- Choice is a simple expression
+
+ else
+ exit Search when Val = Expr_Value (Choice);
+ end if;
+
+ Next (Choice);
+ end loop;
+ end if;
+
+ Next (Alt);
+ pragma Assert (Present (Alt));
+ end loop Search;
+
+ -- The above loop *must* terminate by finding a match, since
+ -- we know the case statement is valid, and the value of the
+ -- expression is known at compile time. When we fall out of
+ -- the loop, Alt points to the alternative that we know will
+ -- be selected at run time.
+
+ return Alt;
+ end Find_Static_Alternative;
+
------------------
-- First_Actual --
------------------
-------------------------
function Full_Qualified_Name (E : Entity_Id) return String_Id is
-
Res : String_Id;
+ pragma Warnings (Off, Res);
function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id;
-- Compute recursively the qualified name without NUL at the end.
+ ----------------------------------
+ -- Internal_Full_Qualified_Name --
+ ----------------------------------
+
function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id is
Ent : Entity_Id := E;
Parent_Name : String_Id := No_String;
return End_String;
end Internal_Full_Qualified_Name;
+ -- Start of processing for Full_Qualified_Name
+
begin
Res := Internal_Full_Qualified_Name (E);
Store_String_Char (Get_Char_Code (ASCII.nul));
if No (Next (Assoc)) then
if not Is_Constrained (Typ)
and then Is_Derived_Type (Typ)
- and then Present (Girder_Constraint (Typ))
+ and then Present (Stored_Constraint (Typ))
then
-- If the type is a tagged type with inherited discriminants,
- -- use the girder constraint on the parent in order to find
+ -- use the stored constraint on the parent in order to find
-- the values of discriminants that are otherwise hidden by an
-- explicit constraint. Renamed discriminants are handled in
-- the code above.
+ -- If several parent discriminants are renamed by a single
+ -- discriminant of the derived type, the call to obtain the
+ -- Corresponding_Discriminant field only retrieves the last
+ -- of them. We recover the constraint on the others from the
+ -- Stored_Constraint as well.
+
declare
D : Entity_Id;
C : Elmt_Id;
begin
D := First_Discriminant (Etype (Typ));
- C := First_Elmt (Girder_Constraint (Typ));
+ C := First_Elmt (Stored_Constraint (Typ));
while Present (D)
and then Present (C)
loop
if Chars (Discrim_Name) = Chars (D) then
- Assoc :=
- Make_Component_Association (Sloc (Typ),
- New_List
- (New_Occurrence_Of (D, Sloc (Typ))),
- Duplicate_Subexpr (Node (C)));
+ if Is_Entity_Name (Node (C))
+ and then Entity (Node (C)) = Entity (Discrim)
+ then
+ -- D is renamed by Discrim, whose value is
+ -- given in Assoc.
+
+ null;
+
+ else
+ Assoc :=
+ Make_Component_Association (Sloc (Typ),
+ New_List
+ (New_Occurrence_Of (D, Sloc (Typ))),
+ Duplicate_Subexpr_No_Checks (Node (C)));
+ end if;
exit Find_Constraint;
end if;
Discrim_Value := Expression (Assoc);
if not Is_OK_Static_Expression (Discrim_Value) then
- Error_Msg_NE
- ("value for discriminant & must be static", Discrim_Value, Discrim);
+ Error_Msg_FE
+ ("value for discriminant & must be static!",
+ Discrim_Value, Discrim);
+ Why_Not_Static (Discrim_Value);
Report_Errors := True;
return;
end if;
-- 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 In_Default_Expression then
return Typ;
+ elsif Is_Private_Type (Typ)
+ and then not Has_Discriminants (Typ)
+ then
+ -- If the type has no discriminants, there is no subtype to
+ -- build, even if the underlying type is discriminated.
+
+ return Typ;
+
-- Else build the actual subtype
else
return
Make_String_Literal (Sloc (E),
Strval => String_From_Name_Buffer);
-
end Get_Default_External_Name;
---------------------------
---------------------------
function Get_Enum_Lit_From_Pos
- (T : Entity_Id;
- Pos : Uint;
- Loc : Source_Ptr)
- return Node_Id
+ (T : Entity_Id;
+ Pos : Uint;
+ Loc : Source_Ptr) return Node_Id
is
Lit : Node_Id;
P : constant Nat := UI_To_Int (Pos);
end if;
end Get_Enum_Lit_From_Pos;
+ ------------------------
+ -- Get_Generic_Entity --
+ ------------------------
+
+ function Get_Generic_Entity (N : Node_Id) return Entity_Id is
+ Ent : constant Entity_Id := Entity (Name (N));
+
+ begin
+ if Present (Renamed_Object (Ent)) then
+ return Renamed_Object (Ent);
+ else
+ return Ent;
+ end if;
+ end Get_Generic_Entity;
+
----------------------
-- Get_Index_Bounds --
----------------------
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_Infinities --
- --------------------
+ -----------------------
+ -- Has_Access_Values --
+ -----------------------
+
+ function Has_Access_Values (T : Entity_Id) return Boolean is
+ Typ : constant Entity_Id := Underlying_Type (T);
- function Has_Infinities (E : Entity_Id) return Boolean is
begin
- return
- Is_Floating_Point_Type (E)
- and then Nkind (Scalar_Range (E)) = N_Range
- and then Includes_Infinities (Scalar_Range (E));
- end Has_Infinities;
+ -- 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.
- ---------------------------
- -- Has_Private_Component --
- ---------------------------
+ if No (Typ) then
+ return False;
- function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
- Btype : Entity_Id := Base_Type (Type_Id);
+ 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 --
+ --------------------
+
+ function Has_Infinities (E : Entity_Id) return Boolean is
+ begin
+ return
+ Is_Floating_Point_Type (E)
+ and then Nkind (Scalar_Range (E)) = N_Range
+ and then Includes_Infinities (Scalar_Range (E));
+ end Has_Infinities;
+
+ ------------------------
+ -- Has_Null_Extension --
+ ------------------------
+
+ function Has_Null_Extension (T : Entity_Id) return Boolean is
+ B : constant Entity_Id := Base_Type (T);
+ Comps : Node_Id;
+ Ext : Node_Id;
+
+ begin
+ if Nkind (Parent (B)) = N_Full_Type_Declaration
+ and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
+ then
+ Ext := Record_Extension_Part (Type_Definition (Parent (B)));
+
+ if Present (Ext) then
+ if Null_Present (Ext) then
+ return True;
+ else
+ Comps := Component_List (Ext);
+
+ -- The null component list is rewritten during analysis to
+ -- include the parent component. Any other component indicates
+ -- that the extension was not originally null.
+
+ return Null_Present (Comps)
+ or else No (Next (First (Component_Items (Comps))));
+ end if;
+ else
+ return False;
+ end if;
+
+ else
+ return False;
+ end if;
+ end Has_Null_Extension;
+
+ ---------------------------
+ -- Has_Private_Component --
+ ---------------------------
+
+ function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
+ Btype : Entity_Id := Base_Type (Type_Id);
Component : Entity_Id;
begin
return False;
end In_Instance_Visible_Part;
+ ----------------------
+ -- In_Packiage_Body --
+ ----------------------
+
+ function In_Package_Body return Boolean is
+ S : Entity_Id := Current_Scope;
+
+ begin
+ while Present (S)
+ and then S /= Standard_Standard
+ loop
+ if Ekind (S) = E_Package
+ and then In_Package_Body (S)
+ then
+ return True;
+ else
+ S := Scope (S);
+ end if;
+ end loop;
+
+ return False;
+ end In_Package_Body;
+
--------------------------------------
-- In_Subprogram_Or_Concurrent_Unit --
--------------------------------------
if K in Subprogram_Kind
or else K in Concurrent_Kind
- or else K = E_Generic_Procedure
- or else K = E_Generic_Function
+ or else K in Generic_Subprogram_Kind
then
return True;
E := Scope (E);
end loop;
-
end In_Subprogram_Or_Concurrent_Unit;
---------------------
and then not In_Private_Part (Scope_Id);
end In_Visible_Part;
+ ---------------------------------
+ -- Insert_Explicit_Dereference --
+ ---------------------------------
+
+ procedure Insert_Explicit_Dereference (N : Node_Id) is
+ New_Prefix : constant Node_Id := Relocate_Node (N);
+ I : Interp_Index;
+ It : Interp;
+ T : Entity_Id;
+
+ begin
+ Save_Interps (N, New_Prefix);
+ Rewrite (N,
+ Make_Explicit_Dereference (Sloc (N), Prefix => New_Prefix));
+
+ Set_Etype (N, Designated_Type (Etype (New_Prefix)));
+
+ if Is_Overloaded (New_Prefix) then
+
+ -- The deference is also overloaded, and its interpretations are the
+ -- designated types of the interpretations of the original node.
+
+ Set_Etype (N, Any_Type);
+ Get_First_Interp (New_Prefix, I, It);
+
+ while Present (It.Nam) loop
+ T := It.Typ;
+
+ if Is_Access_Type (T) then
+ Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ End_Interp_List;
+ end if;
+ end Insert_Explicit_Dereference;
+
-------------------
-- Is_AAMP_Float --
-------------------
or else Nkind (Obj) = N_Type_Conversion
then
return Is_Tagged_Type (Etype (Obj))
- or else Is_Aliased_View (Expression (Obj));
+ and then Is_Aliased_View (Expression (Obj));
elsif Nkind (Obj) = N_Explicit_Dereference then
return Nkind (Original_Node (Obj)) /= N_Function_Call;
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 --
----------------------
----------------------------------------------
function Is_Dependent_Component_Of_Mutable_Object
- (Object : Node_Id)
- return Boolean
+ (Object : Node_Id) return Boolean
is
P : Node_Id;
Prefix_Type : Entity_Id;
------------------------------
function Has_Dependent_Constraint (Comp : Entity_Id) return Boolean is
- Comp_Decl : constant Node_Id := Parent (Comp);
- Subt_Indic : constant Node_Id := Subtype_Indication (Comp_Decl);
+ Comp_Decl : constant Node_Id := Parent (Comp);
+ Subt_Indic : constant Node_Id :=
+ Subtype_Indication (Component_Definition (Comp_Decl));
Constr : Node_Id;
Assn : Node_Id;
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)
Comp :=
Original_Record_Component (Entity (Selector_Name (Object)));
+ -- As per AI-0017, the renaming is illegal in a generic body,
+ -- even if the subtype is indefinite.
+
if not Is_Constrained (Prefix_Type)
- and then not Is_Indefinite_Subtype (Prefix_Type)
+ and then (not Is_Indefinite_Subtype (Prefix_Type)
+ or else
+ (Is_Generic_Type (Prefix_Type)
+ and then Ekind (Current_Scope) = E_Generic_Package
+ and then In_Package_Body (Current_Scope)))
+
and then (Is_Declared_Within_Variant (Comp)
or else Has_Dependent_Constraint (Comp))
and then not P_Aliased
or else Nkind (Object) = N_Slice
then
return Is_Dependent_Component_Of_Mutable_Object (Prefix (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;
return False;
end Is_Dependent_Component_Of_Mutable_Object;
+ ---------------------
+ -- Is_Dereferenced --
+ ---------------------
+
+ function Is_Dereferenced (N : Node_Id) return Boolean is
+ P : constant Node_Id := Parent (N);
+
+ begin
+ return
+ (Nkind (P) = N_Selected_Component
+ or else
+ Nkind (P) = N_Explicit_Dereference
+ or else
+ Nkind (P) = N_Indexed_Component
+ or else
+ Nkind (P) = N_Slice)
+ 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 --
--------------
end;
end if;
+ -- If no null indexes, then type is not fully initialized
+
return False;
+ -- Record types
+
elsif Is_Record_Type (Typ) then
+ if Has_Discriminants (Typ)
+ and then
+ Present (Discriminant_Default_Value (First_Discriminant (Typ)))
+ and then Is_Fully_Initialized_Variant (Typ)
+ then
+ return True;
+ end if;
+
+ -- Controlled records are considered to be fully initialized if
+ -- there is a user defined Initialize routine. This may not be
+ -- entirely correct, but as the spec notes, we are guessing here
+ -- what is best from the point of view of issuing warnings.
+
+ if Is_Controlled (Typ) then
+ declare
+ Utyp : constant Entity_Id := Underlying_Type (Typ);
+
+ begin
+ if Present (Utyp) then
+ declare
+ Init : constant Entity_Id :=
+ (Find_Prim_Op
+ (Underlying_Type (Typ), Name_Initialize));
+
+ begin
+ if Present (Init)
+ and then Comes_From_Source (Init)
+ and then not
+ Is_Predefined_File_Name
+ (File_Name (Get_Source_File_Index (Sloc (Init))))
+ then
+ return True;
+
+ elsif Has_Null_Extension (Typ)
+ and then
+ Is_Fully_Initialized_Type
+ (Etype (Base_Type (Typ)))
+ then
+ return True;
+ end if;
+ end;
+ end if;
+ end;
+ end if;
+
+ -- Otherwise see if all record components are initialized
+
declare
Ent : Entity_Id;
Ent := First_Entity (Typ);
while Present (Ent) loop
- if Ekind (Ent) = E_Component
+ if Chars (Ent) = Name_uController then
+ null;
+
+ elsif Ekind (Ent) = E_Component
and then (No (Parent (Ent))
or else No (Expression (Parent (Ent))))
and then not Is_Fully_Initialized_Type (Etype (Ent))
end loop;
end;
+ -- No uninitialized components, so type is fully initialized.
+ -- Note that this catches the case of no components as well.
+
return True;
elsif Is_Concurrent_Type (Typ) then
end if;
end Is_Fully_Initialized_Type;
+ ----------------------------------
+ -- Is_Fully_Initialized_Variant --
+ ----------------------------------
+
+ function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Constraints : constant List_Id := New_List;
+ Components : constant Elist_Id := New_Elmt_List;
+ Comp_Elmt : Elmt_Id;
+ Comp_Id : Node_Id;
+ Comp_List : Node_Id;
+ Discr : Entity_Id;
+ Discr_Val : Node_Id;
+ Report_Errors : Boolean;
+
+ begin
+ if Serious_Errors_Detected > 0 then
+ return False;
+ end if;
+
+ if Is_Record_Type (Typ)
+ and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
+ and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition
+ then
+ Comp_List := Component_List (Type_Definition (Parent (Typ)));
+ Discr := First_Discriminant (Typ);
+
+ while Present (Discr) loop
+ if Nkind (Parent (Discr)) = N_Discriminant_Specification then
+ Discr_Val := Expression (Parent (Discr));
+
+ 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;
+ end if;
+
+ Next_Discriminant (Discr);
+ end loop;
+
+ Gather_Components
+ (Typ => Typ,
+ Comp_List => Comp_List,
+ Governed_By => Constraints,
+ Into => Components,
+ Report_Errors => Report_Errors);
+
+ -- Check that each component present is fully initialized.
+
+ Comp_Elmt := First_Elmt (Components);
+
+ while Present (Comp_Elmt) loop
+ Comp_Id := Node (Comp_Elmt);
+
+ if Ekind (Comp_Id) = E_Component
+ and then (No (Parent (Comp_Id))
+ or else No (Expression (Parent (Comp_Id))))
+ and then not Is_Fully_Initialized_Type (Etype (Comp_Id))
+ then
+ return False;
+ end if;
+
+ Next_Elmt (Comp_Elmt);
+ end loop;
+
+ return True;
+
+ elsif Is_Private_Type (Typ) then
+ declare
+ U : constant Entity_Id := Underlying_Type (Typ);
+
+ begin
+ if No (U) then
+ return False;
+ else
+ return Is_Fully_Initialized_Variant (U);
+ end if;
+ end;
+ else
+ return False;
+ end if;
+ end Is_Fully_Initialized_Variant;
+
----------------------------
-- Is_Inherited_Operation --
----------------------------
function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
begin
+ -- The following is a small optimization, and it also handles
+ -- properly discriminals, which in task bodies might appear in
+ -- expressions before the corresponding procedure has been
+ -- created, and which therefore do not have an assigned scope.
+
+ if Ekind (E) in Formal_Kind then
+ return False;
+ end if;
+
+ -- Normal test is simply that the enclosing dynamic scope is Standard
+
return Enclosing_Dynamic_Scope (E) = Standard_Standard;
end Is_Library_Level_Entity;
end if;
end Is_Local_Variable_Reference;
+ ---------------
+ -- Is_Lvalue --
+ ---------------
+
+ function Is_Lvalue (N : Node_Id) return Boolean is
+ P : constant Node_Id := Parent (N);
+
+ begin
+ case Nkind (P) is
+
+ -- Test left side of assignment
+
+ when N_Assignment_Statement =>
+ return N = Name (P);
+
+ -- Test prefix of component or attribute
+
+ when N_Attribute_Reference |
+ N_Expanded_Name |
+ N_Explicit_Dereference |
+ N_Indexed_Component |
+ N_Reference |
+ N_Selected_Component |
+ N_Slice =>
+ return N = Prefix (P);
+
+ -- Test subprogram parameter (we really should check the
+ -- parameter mode, but it is not worth the trouble)
+
+ when N_Function_Call |
+ N_Procedure_Call_Statement |
+ N_Accept_Statement |
+ N_Parameter_Association =>
+ return True;
+
+ -- Test for appearing in a conversion that itself appears
+ -- in an lvalue context, since this should be an lvalue.
+
+ when N_Type_Conversion =>
+ return Is_Lvalue (P);
+
+ -- Test for appearence in object renaming declaration
+
+ when N_Object_Renaming_Declaration =>
+ return True;
+
+ -- All other references are definitely not Lvalues
+
+ when others =>
+ return False;
+
+ end case;
+ end Is_Lvalue;
+
-------------------------
-- Is_Object_Reference --
-------------------------
else
case Nkind (N) is
when N_Indexed_Component | N_Slice =>
- return True;
+ return Is_Object_Reference (Prefix (N));
- -- In Ada95, a function call is a constant object.
+ -- In Ada95, a function call is a constant object
when N_Function_Call =>
return True;
+ -- A reference to the stream attribute Input is a function call
+
+ when N_Attribute_Reference =>
+ 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;
+ -- A view conversion of a tagged object is an object reference.
+
+ when N_Type_Conversion =>
+ return Is_Tagged_Type (Etype (Subtype_Mark (N)))
+ and then Is_Tagged_Type (Etype (Expression (N)))
+ and then Is_Object_Reference (Expression (N));
+
-- An unchecked type conversion is considered to be an object if
-- the operand is an object (this construction arises only as a
-- result of expansion activities).
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;
-- If this node is rewritten, then test the original form, if that is
-- OK, then we consider the rewritten node OK (for example, if the
-- original node is a conversion, then Is_Variable will not be true
- -- but we still want to allow the conversion if it converts a variable.
+ -- but we still want to allow the conversion if it converts a variable).
elsif Original_Node (AV) /= AV then
return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
end if;
end Is_OK_Variable_For_Out_Formal;
+ -----------------------------------
+ -- Is_Partially_Initialized_Type --
+ -----------------------------------
+
+ function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean is
+ begin
+ if Is_Scalar_Type (Typ) then
+ return False;
+
+ elsif Is_Access_Type (Typ) then
+ return True;
+
+ elsif Is_Array_Type (Typ) then
+
+ -- If component type is partially initialized, so is array type
+
+ if Is_Partially_Initialized_Type (Component_Type (Typ)) then
+ return True;
+
+ -- Otherwise we are only partially initialized if we are fully
+ -- initialized (this is the empty array case, no point in us
+ -- duplicating that code here).
+
+ else
+ return Is_Fully_Initialized_Type (Typ);
+ end if;
+
+ elsif Is_Record_Type (Typ) then
+
+ -- A discriminated type is always partially initialized
+
+ if Has_Discriminants (Typ) then
+ return True;
+
+ -- A tagged type is always partially initialized
+
+ elsif Is_Tagged_Type (Typ) then
+ return True;
+
+ -- Case of non-discriminated record
+
+ else
+ declare
+ Ent : Entity_Id;
+
+ Component_Present : Boolean := False;
+ -- Set True if at least one component is present. If no
+ -- components are present, then record type is fully
+ -- initialized (another odd case, like the null array).
+
+ begin
+ -- Loop through components
+
+ Ent := First_Entity (Typ);
+ while Present (Ent) loop
+ if Ekind (Ent) = E_Component then
+ Component_Present := True;
+
+ -- If a component has an initialization expression then
+ -- the enclosing record type is partially initialized
+
+ if Present (Parent (Ent))
+ and then Present (Expression (Parent (Ent)))
+ then
+ return True;
+
+ -- If a component is of a type which is itself partially
+ -- initialized, then the enclosing record type is also.
+
+ elsif Is_Partially_Initialized_Type (Etype (Ent)) then
+ return True;
+ end if;
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+
+ -- No initialized components found. If we found any components
+ -- they were all uninitialized so the result is false.
+
+ if Component_Present then
+ return False;
+
+ -- But if we found no components, then all the components are
+ -- initialized so we consider the type to be initialized.
+
+ else
+ return True;
+ end if;
+ end;
+ end if;
+
+ -- Concurrent types are always fully initialized
+
+ elsif Is_Concurrent_Type (Typ) then
+ return True;
+
+ -- For a private type, go to underlying type. If there is no underlying
+ -- type then just assume this partially initialized. Not clear if this
+ -- can happen in a non-error case, but no harm in testing for this.
+
+ elsif Is_Private_Type (Typ) then
+ declare
+ U : constant Entity_Id := Underlying_Type (Typ);
+
+ begin
+ if No (U) then
+ return True;
+ else
+ return Is_Partially_Initialized_Type (U);
+ end if;
+ end;
+
+ -- For any other type (are there any?) assume partially initialized
+
+ else
+ return True;
+ end if;
+ end Is_Partially_Initialized_Type;
+
-----------------------------
-- Is_RCI_Pkg_Spec_Or_Body --
-----------------------------
-----------------------------------------
function Is_Remote_Access_To_Class_Wide_Type
- (E : Entity_Id)
- return Boolean
+ (E : Entity_Id) return Boolean
is
D : Entity_Id;
function Comes_From_Limited_Private_Type_Declaration
(E : Entity_Id)
return Boolean;
- -- Check if the original declaration is a limited private one and
- -- if all the derivations have been using private extensions.
+ -- Check that the type is declared by a limited type declaration,
+ -- or else is derived from a Remote_Type ancestor through private
+ -- extensions.
-------------------------------------------------
-- Comes_From_Limited_Private_Type_Declaration --
end if;
if Nkind (N) = N_Private_Extension_Declaration then
- return Comes_From_Limited_Private_Type_Declaration (Etype (E));
+ return
+ Comes_From_Limited_Private_Type_Declaration (Etype (E))
+ or else
+ (Is_Remote_Types (Etype (E))
+ and then Is_Limited_Record (Etype (E))
+ and then Has_Private_Declaration (Etype (E)));
end if;
return False;
-----------------------------------------
function Is_Remote_Access_To_Subprogram_Type
- (E : Entity_Id)
- return Boolean
+ (E : Entity_Id) return Boolean
is
begin
return (Ekind (E) = E_Access_Subprogram_Type
-- must test for the case of a reference of a constant access
-- type, which can never be a variable.
+ ---------------------------
+ -- In_Protected_Function --
+ ---------------------------
+
function In_Protected_Function (E : Entity_Id) return Boolean is
Prot : constant Entity_Id := Scope (E);
S : Entity_Id;
end if;
end In_Protected_Function;
+ ------------------------
+ -- Is_Variable_Prefix --
+ ------------------------
+
function Is_Variable_Prefix (P : Node_Id) return Boolean is
begin
if Is_Access_Type (Etype (P)) then
return Is_Variable_Prefix (Prefix (Orig_Node))
and then Is_Variable (Selector_Name (Orig_Node));
- -- For an explicit dereference, we must check whether the type
- -- is ACCESS CONSTANT, since if it is, then it is not a variable.
+ -- For an explicit dereference, the type of the prefix cannot
+ -- be an access to constant or an access to subprogram.
when N_Explicit_Dereference =>
- return Is_Access_Type (Etype (Prefix (Orig_Node)))
- and then not
- Is_Access_Constant (Root_Type (Etype (Prefix (Orig_Node))));
+ declare
+ Typ : constant Entity_Id := Etype (Prefix (Orig_Node));
+
+ begin
+ return Is_Access_Type (Typ)
+ and then not Is_Access_Constant (Root_Type (Typ))
+ and then Ekind (Typ) /= E_Access_Subprogram_Type;
+ end;
-- The type conversion is the case where we do not deal with the
-- context dependent special case of an actual parameter. Thus
function Is_Volatile_Prefix (N : Node_Id) return Boolean;
-- If prefix is an implicit dereference, examine designated type.
+ ------------------------
+ -- Is_Volatile_Prefix --
+ ------------------------
+
function Is_Volatile_Prefix (N : Node_Id) return Boolean is
+ Typ : constant Entity_Id := Etype (N);
+
begin
- if Is_Access_Type (Etype (N)) then
- return Has_Volatile_Components (Designated_Type (Etype (N)));
+ if Is_Access_Type (Typ) then
+ declare
+ Dtyp : constant Entity_Id := Designated_Type (Typ);
+
+ begin
+ return Is_Volatile (Dtyp)
+ or else Has_Volatile_Components (Dtyp);
+ end;
+
else
return Object_Has_Volatile_Components (N);
end if;
end Is_Volatile_Prefix;
+ ------------------------------------
+ -- Object_Has_Volatile_Components --
+ ------------------------------------
+
function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
+ Typ : constant Entity_Id := Etype (N);
+
begin
- if Is_Volatile (Etype (N))
- or else Has_Volatile_Components (Etype (N))
+ if Is_Volatile (Typ)
+ or else Has_Volatile_Components (Typ)
then
return True;
end if;
end Is_Volatile_Object;
+ -------------------------
+ -- Kill_Current_Values --
+ -------------------------
+
+ procedure Kill_Current_Values is
+ S : Entity_Id;
+
+ 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 --
+ ------------------------------------------
+
+ procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
+ Ent : Entity_Id;
+
+ begin
+ Ent := E;
+ while Present (Ent) loop
+ if Is_Object (Ent) then
+ Set_Current_Value (Ent, Empty);
+
+ if not Can_Never_Be_Null (Ent) then
+ Set_Is_Known_Non_Null (Ent, False);
+ end if;
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+ end Kill_Current_Values_For_Entity_Chain;
+
+ -- Start of processing for Kill_Current_Values
+
+ begin
+ -- Kill all saved checks, a special case of killing saved values
+
+ Kill_All_Checks;
+
+ -- Loop through relevant scopes, which includes the current scope and
+ -- any parent scopes if the current scope is a block or a package.
+
+ S := Current_Scope;
+ Scope_Loop : loop
+
+ -- Clear current values of all entities in current scope
+
+ Kill_Current_Values_For_Entity_Chain (First_Entity (S));
+
+ -- If scope is a package, also clear current values of all
+ -- private entities in the scope.
+
+ if Ekind (S) = E_Package
+ or else
+ Ekind (S) = E_Generic_Package
+ or else
+ Is_Concurrent_Type (S)
+ then
+ Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S));
+ end if;
+
+ -- If this is a block or nested package, deal with parent
+
+ if Ekind (S) = E_Block
+ or else (Ekind (S) = E_Package
+ and then not Is_Library_Level_Entity (S))
+ then
+ S := Scope (S);
+ else
+ exit Scope_Loop;
+ end if;
+ end loop Scope_Loop;
+ end Kill_Current_Values;
+
--------------------------
-- Kill_Size_Check_Code --
--------------------------
Related_Id : Entity_Id;
Suffix : Character;
Suffix_Index : Nat := 0;
- Prefix : Character := ' ')
- return Entity_Id
+ Prefix : Character := ' ') return Entity_Id
is
N : constant Entity_Id :=
Make_Defining_Identifier (Sloc_Value,
(Kind : Entity_Kind;
Scope_Id : Entity_Id;
Sloc_Value : Source_Ptr;
- Id_Char : Character)
- return Entity_Id
+ Id_Char : Character) return Entity_Id
is
N : constant Entity_Id :=
Make_Defining_Identifier (Sloc_Value, New_Internal_Name (Id_Char));
function Reporting return Boolean;
-- Determines if an error is to be reported. To report an error, we
-- need Report to be True, and also we do not report errors caused
- -- by calls to Init_Proc's that occur within other Init_Proc's. Such
+ -- by calls to init procs that occur within other init procs. Such
-- errors must always be cascaded errors, since if all the types are
-- declared correctly, the compiler will certainly build decent calls!
+ -----------
+ -- Chain --
+ -----------
+
procedure Chain (A : Node_Id) is
begin
if No (Last) then
Set_Next_Named_Actual (Last, Empty);
end Chain;
+ ---------------
+ -- Reporting --
+ ---------------
+
function Reporting return Boolean is
begin
if not Report then
elsif not Within_Init_Proc then
return True;
- elsif Chars (Entity (Name (N))) = Name_uInit_Proc then
+ elsif Is_Init_Proc (Entity (Name (N))) then
return False;
else
-- Too many actuals: will not work.
if Reporting then
- Error_Msg_N ("too many arguments in call", N);
+ if Is_Entity_Name (Name (N)) then
+ Error_Msg_N ("too many arguments in call to&", Name (N));
+ else
+ Error_Msg_N ("too many arguments in call", N);
+ end if;
end if;
Success := False;
end if;
Formal := First_Formal (S);
-
while Present (Formal) loop
-- Match the formals in order. If the corresponding actual
or else No (Default_Value (Formal))
then
if Reporting then
- if Comes_From_Source (S)
+ if (Comes_From_Source (S)
+ or else Sloc (S) = Standard_Location)
and then Is_Overloadable (S)
then
+ if No (Actuals)
+ and then
+ (Nkind (Parent (N)) = N_Procedure_Call_Statement
+ or else
+ (Nkind (Parent (N)) = N_Function_Call
+ or else
+ Nkind (Parent (N)) = N_Parameter_Association))
+ and then Ekind (S) /= E_Function
+ then
+ Set_Etype (N, Etype (S));
+ else
+ Error_Msg_Name_1 := Chars (S);
+ Error_Msg_Sloc := Sloc (S);
+ Error_Msg_NE
+ ("missing argument for parameter & " &
+ "in call to % declared #", N, Formal);
+ end if;
+
+ elsif Is_Overloadable (S) then
Error_Msg_Name_1 := Chars (S);
- Error_Msg_Sloc := Sloc (S);
+
+ -- Point to type derivation that generated the
+ -- operation.
+
+ Error_Msg_Sloc := Sloc (Parent (S));
+
Error_Msg_NE
("missing argument for parameter & " &
- "in call to % declared #", N, Formal);
+ "in call to % (inherited) #", N, Formal);
+
else
Error_Msg_NE
("missing argument for parameter &", N, Formal);
Actual := First (Actuals);
while Present (Actual) loop
-
if Nkind (Actual) = N_Parameter_Association
and then Actual /= Last
and then No (Next_Named_Actual (Actual))
then
- Error_Msg_N ("Unmatched actual in call", Actual);
+ Error_Msg_N ("unmatched actual & in call",
+ Selector_Name (Actual));
exit;
end if;
--------------------------------
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
-
- procedure Set_Ref (E : Entity_Id; N : Node_Id) is
- begin
- Set_Not_Source_Assigned (E, False);
- Set_Is_True_Constant (E, False);
- Generate_Reference (E, N, 'm');
- 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)
+ <<Continue>>
+ Ent := Empty;
- if Nkind (Exp) = N_Explicit_Dereference
- and then Is_Entity_Name (Original_Node (Exp))
- then
- Set_Ref (Entity (Original_Node (Exp)), Original_Node (Exp));
- return;
-
- elsif Is_Entity_Name (Exp) then
+ 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
- Exp := Renamed_Object (Ent);
+ elsif Nkind (Exp) = N_Explicit_Dereference then
+ declare
+ P : constant Node_Id := Prefix (Exp);
- else
- Set_Ref (Ent, Exp);
- return;
- 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
+
+ Ent := Entry_Formal (Entity (Selector_Name (P)));
+
+ 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;
return Type_Access_Level (Etype (Prefix (Obj)));
end if;
- elsif Nkind (Obj) = N_Type_Conversion then
+ elsif Nkind (Obj) = N_Type_Conversion
+ or else Nkind (Obj) = N_Unchecked_Type_Conversion
+ then
return Object_Access_Level (Expression (Obj));
-- Function results are objects, so we get either the access level
function Trace_Components
(T : Entity_Id;
- Check : Boolean)
- return Entity_Id;
+ Check : Boolean) return Entity_Id;
-- Recursive function that does the work, and checks against circular
-- definition for each subcomponent type.
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);
-- Process_End_Label --
-----------------------
- procedure Process_End_Label (N : Node_Id; Typ : Character) is
+ procedure Process_End_Label
+ (N : Node_Id;
+ Typ : Character;
+ Ent : Entity_Id)
+ is
Loc : Source_Ptr;
Nam : Node_Id;
- Ctyp : Entity_Id;
Label_Ref : Boolean;
-- Set True if reference to end label itself is required
-- the entity Ent. For the child unit case, this is the identifier
-- from the designator. For other cases, this is simply Endl.
- Ent : Entity_Id;
- -- This is the entity for the construct to which the End_Label applies
-
procedure Generate_Parent_Ref (N : Node_Id);
-- N is an identifier node that appears as a parent unit reference
-- in the case where Ent is a child unit. This procedure generates
-- an appropriate cross-reference entry.
+ -------------------------
+ -- Generate_Parent_Ref --
+ -------------------------
+
procedure Generate_Parent_Ref (N : Node_Id) is
Parent_Ent : Entity_Id;
-- Nothing to do if no End_Label, happens for internally generated
-- constructs where we don't want an end label reference anyway.
+ -- Also nothing to do if Endl is a string literal, which means
+ -- there was some prior error (bad operator symbol)
Endl := End_Label (N);
- if No (Endl) then
+ if No (Endl) or else Nkind (Endl) = N_String_Literal then
return;
end if;
end if;
end if;
- -- Locate the entity to which the end label applies. Most of the
- -- time this is simply the current scope containing the construct.
-
- Ent := Current_Scope;
-
- if Chars (Ent) = Chars (Endl) then
- null;
-
- -- But in the case of single tasks and single protected objects,
- -- the current scope is the anonymous task or protected type and
- -- what we want is the object. There is no direct link so what we
- -- do is search ahead in the entity chain for the object with the
- -- matching type and name. In practice it is almost certain to be
- -- the very next entity on the chain, so this is not inefficient.
-
- else
- Ctyp := Etype (Ent);
- loop
- Next_Entity (Ent);
-
- -- If we don't find the entry we are looking for, that's
- -- odd, perhaps results from some error condition? Anyway
- -- the appropriate thing is just to abandon the attempt.
+ -- If the end label is not for the given entity, then either we have
+ -- some previous error, or this is a generic instantiation for which
+ -- we do not need to make a cross-reference in this case anyway. In
+ -- either case we simply ignore the call.
- if No (Ent) then
- return;
-
- -- Exit if we find the entity we are looking for
-
- elsif Etype (Ent) = Ctyp
- and then Chars (Ent) = Chars (Endl)
- then
- exit;
- end if;
- end loop;
+ if Chars (Ent) /= Chars (Endl) then
+ return;
end if;
-- If label was really there, then generate a normal reference
if Comes_From_Source (Endl) then
-- If a label reference is required, then do the style check
- -- and generate a normal cross-reference entry for the label
+ -- and generate an l-type cross-reference entry for the label
if Label_Ref then
- Style.Check_Identifier (Endl, Ent);
- Generate_Reference (Ent, Endl, 'r', Set_Ref => False);
+ if Style_Check then
+ Style.Check_Identifier (Endl, Ent);
+ end if;
+ Generate_Reference (Ent, Endl, 'l', Set_Ref => False);
end if;
-- Set the location to point past the label (normally this will
return Token_Node;
end Real_Convert;
+ ---------------------
+ -- Rep_To_Pos_Flag --
+ ---------------------
+
+ function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
+ begin
+ return New_Occurrence_Of
+ (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc);
+ end Rep_To_Pos_Flag;
+
+ --------------------
+ -- Require_Entity --
+ --------------------
+
+ procedure Require_Entity (N : Node_Id) is
+ begin
+ if Is_Entity_Name (N) and then No (Entity (N)) then
+ if Total_Errors_Detected /= 0 then
+ Set_Entity (N, Any_Id);
+ else
+ raise Program_Error;
+ end if;
+ end if;
+ end Require_Entity;
+
------------------------------
-- Requires_Transient_Scope --
------------------------------
-- 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;
--------------------------
procedure Reset_Analyzed_Flags (N : Node_Id) is
function Clear_Analyzed
- (N : Node_Id)
- return Traverse_Result;
+ (N : Node_Id) return Traverse_Result;
-- Function used to reset Analyzed flags in tree. Note that we do
-- not reset Analyzed flags in entities, since there is no need to
-- renalalyze entities, and indeed, it is wrong to do so, since it
-- can result in generating auxiliary stuff more than once.
+ --------------------
+ -- Clear_Analyzed --
+ --------------------
+
function Clear_Analyzed
- (N : Node_Id)
- return Traverse_Result
+ (N : Node_Id) return Traverse_Result
is
begin
if not Has_Extension (N) then
new Traverse_Func (Clear_Analyzed);
Discard : Traverse_Result;
+ pragma Warnings (Off, Discard);
-- Start of processing for Reset_Analyzed_Flags
Discard := Reset_Analyzed (N);
end Reset_Analyzed_Flags;
+ ---------------------------
+ -- Safe_To_Capture_Value --
+ ---------------------------
+
+ function Safe_To_Capture_Value
+ (N : Node_Id;
+ Ent : Entity_Id) return Boolean
+ is
+ begin
+ -- The only entities for which we track constant values are variables,
+ -- out parameters and in out parameters, so check if we have this case.
+
+ if Ekind (Ent) /= E_Variable
+ and then
+ Ekind (Ent) /= E_Out_Parameter
+ and then
+ Ekind (Ent) /= E_In_Out_Parameter
+ then
+ return False;
+ end if;
+
+ -- Skip volatile and aliased variables, since funny things might
+ -- be going on in these cases which we cannot necessarily track.
+
+ if Treat_As_Volatile (Ent) or else Is_Aliased (Ent) then
+ return False;
+ end if;
+
+ -- OK, all above conditions are met. We also require that the scope
+ -- of the reference be the same as the scope of the entity, not
+ -- counting packages and blocks.
+
+ declare
+ E_Scope : constant Entity_Id := Scope (Ent);
+ R_Scope : Entity_Id;
+
+ begin
+ R_Scope := Current_Scope;
+ while R_Scope /= Standard_Standard loop
+ exit when R_Scope = E_Scope;
+
+ if Ekind (R_Scope) /= E_Package
+ and then
+ Ekind (R_Scope) /= E_Block
+ then
+ return False;
+ else
+ R_Scope := Scope (R_Scope);
+ end if;
+ end loop;
+ end;
+
+ -- We also require that the reference does not appear in a context
+ -- where it is not sure to be executed (i.e. a conditional context
+ -- or an exception handler).
+
+ declare
+ P : Node_Id;
+
+ begin
+ P := Parent (N);
+ while Present (P) loop
+ if Nkind (P) = N_If_Statement
+ or else
+ Nkind (P) = N_Case_Statement
+ or else
+ Nkind (P) = N_Exception_Handler
+ or else
+ Nkind (P) = N_Selective_Accept
+ or else
+ Nkind (P) = N_Conditional_Entry_Call
+ or else
+ Nkind (P) = N_Timed_Entry_Call
+ or else
+ Nkind (P) = N_Asynchronous_Select
+ then
+ return False;
+ else
+ P := Parent (P);
+ end if;
+ end loop;
+ end;
+
+ -- OK, looks safe to set value
+
+ return True;
+ end Safe_To_Capture_Value;
+
---------------
-- Same_Name --
---------------
while not Comes_From_Source (Val_Actual)
and then Nkind (Val_Actual) in N_Entity
and then (Ekind (Val_Actual) = E_Enumeration_Literal
- or else Ekind (Val_Actual) = E_Function
- or else Ekind (Val_Actual) = E_Generic_Function
- or else Ekind (Val_Actual) = E_Procedure
- or else Ekind (Val_Actual) = E_Generic_Procedure)
+ or else Is_Subprogram (Val_Actual)
+ or else Is_Generic_Subprogram (Val_Actual))
and then Present (Alias (Val_Actual))
loop
Val_Actual := Alias (Val_Actual);
if Chars (Nod) = Chars (Val_Actual) then
Style.Check_Identifier (Nod, Val_Actual);
end if;
-
end if;
Set_Entity (N, Val);
then
Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2));
end if;
-
Set_Alignment (T1, Alignment (T2));
end Set_Size_Info;
return No_Uint;
else
- Error_Msg_N ("static integer expression required here", N);
+ Flag_Non_Static_Expr
+ ("static integer expression required here", N);
return No_Uint;
end if;
end Static_Integer;
-----------------------
function Type_Access_Level (Typ : Entity_Id) return Uint is
- Btyp : Entity_Id := Base_Type (Typ);
+ Btyp : Entity_Id;
begin
-- If the type is an anonymous access type we treat it as being
-- 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;
and then Nkind (N) /= N_Package_Instantiation
and then Nkind (N) /= N_Package_Renaming_Declaration
and then Nkind (N) /= N_Procedure_Instantiation
+ and then Nkind (N) /= N_Protected_Body
and then Nkind (N) /= N_Subprogram_Declaration
and then Nkind (N) /= N_Subprogram_Body
and then Nkind (N) /= N_Subprogram_Body_Stub
return N;
end Unit_Declaration_Node;
+ ------------------------------
+ -- Universal_Interpretation --
+ ------------------------------
+
+ function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
+ Index : Interp_Index;
+ It : Interp;
+
+ begin
+ -- The argument may be a formal parameter of an operator or subprogram
+ -- with multiple interpretations, or else an expression for an actual.
+
+ if Nkind (Opnd) = N_Defining_Identifier
+ or else not Is_Overloaded (Opnd)
+ then
+ if Etype (Opnd) = Universal_Integer
+ or else Etype (Opnd) = Universal_Real
+ then
+ return Etype (Opnd);
+ else
+ return Empty;
+ end if;
+
+ else
+ Get_First_Interp (Opnd, Index, It);
+
+ while Present (It.Typ) loop
+
+ if It.Typ = Universal_Integer
+ or else It.Typ = Universal_Real
+ then
+ return It.Typ;
+ end if;
+
+ Get_Next_Interp (Index, It);
+ end loop;
+
+ return Empty;
+ end if;
+ end Universal_Interpretation;
+
----------------------
-- Within_Init_Proc --
----------------------
end if;
end loop;
- return Chars (S) = Name_uInit_Proc;
+ return Is_Init_Proc (S);
end Within_Init_Proc;
----------------
elsif In_Instance then
if Etype (Etype (Expr)) = Etype (Expected_Type)
+ and then
+ (Has_Private_Declaration (Expected_Type)
+ or else Has_Private_Declaration (Etype (Expr)))
and then No (Parent (Expected_Type))
then
return;
or else
Ekind (Entity (Expr)) = E_Generic_Procedure)
then
- Error_Msg_N ("found procedure name instead of function!", Expr);
+ if Ekind (Expec_Type) = E_Access_Subprogram_Type then
+ Error_Msg_N
+ ("found procedure name, possibly missing Access attribute!",
+ Expr);
+ else
+ Error_Msg_N ("found procedure name instead of function!", Expr);
+ end if;
+
+ elsif Nkind (Expr) = N_Function_Call
+ and then Ekind (Expec_Type) = E_Access_Subprogram_Type
+ and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
+ and then No (Parameter_Associations (Expr))
+ then
+ Error_Msg_N
+ ("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
Error_Msg_N (
"operator of the type is not directly visible!", Expr);
+ elsif Ekind (Found_Type) = E_Void
+ and then Present (Parent (Found_Type))
+ and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration
+ then
+ Error_Msg_NE ("found premature usage of}!", Expr, Found_Type);
+
else
Error_Msg_NE ("found}!", Expr, Found_Type);
end if;
OSDN Git Service
