-- --
-- B o d y --
-- --
--- --
--- Copyright (C) 1992-2002, 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 Exp_Ch11; use Exp_Ch11;
with Exp_Pakd; use Exp_Pakd;
with Exp_Util; use Exp_Util;
+with Exp_Tss; use Exp_Tss;
with Layout; use Layout;
with Lib.Xref; use Lib.Xref;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
+with Rident; use Rident;
with Sem; use Sem;
with Sem_Cat; use Sem_Cat;
with Sem_Ch6; use Sem_Ch6;
After : in out Node_Id);
-- Build body for a renaming declaration, insert in tree and analyze.
+ procedure Check_Address_Clause (E : Entity_Id);
+ -- Apply legality checks to address clauses for object declarations,
+ -- at the point the object is frozen.
+
procedure Check_Strict_Alignment (E : Entity_Id);
-- E is a base type. If E is tagged or has a component that is aliased
-- or tagged or contains something this is aliased or tagged, set
-- a subprogram type (i.e. an access to a subprogram).
function Is_Fully_Defined (T : Entity_Id) return Boolean;
- -- true if T is not private, or has a full view.
+ -- True if T is not private and has no private components, or has a full
+ -- view. Used to determine whether the designated type of an access type
+ -- should be frozen when the access type is frozen. This is done when an
+ -- allocator is frozen, or an expression that may involve attributes of
+ -- the designated type. Otherwise freezing the access type does not freeze
+ -- the designated type.
procedure Process_Default_Expressions
(E : Entity_Id;
-- needed -- see body for details). Never has any effect on T if the
-- Debug_Info_Off flag is set.
+ procedure Warn_Overlay
+ (Expr : Node_Id;
+ Typ : Entity_Id;
+ Nam : Node_Id);
+ -- Expr is the expression for an address clause for entity Nam whose type
+ -- is Typ. If Typ has a default initialization, and there is no explicit
+ -- initialization in the source declaration, check whether the address
+ -- clause might cause overlaying of an entity, and emit a warning on the
+ -- side effect that the initialization will cause.
+
-------------------------------
-- Adjust_Esize_For_Alignment --
-------------------------------
function Build_Renamed_Body
(Decl : Node_Id;
- New_S : Entity_Id)
- return Node_Id
+ New_S : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (New_S);
-- We use for the source location of the renamed body, the location
Old_S := Etype (Nam);
elsif Nkind (Nam) = N_Indexed_Component then
-
if Is_Entity_Name (Prefix (Nam)) then
Old_S := Entity (Prefix (Nam));
else
return Body_Node;
end Build_Renamed_Body;
+ --------------------------
+ -- Check_Address_Clause --
+ --------------------------
+
+ procedure Check_Address_Clause (E : Entity_Id) is
+ Addr : constant Node_Id := Address_Clause (E);
+ Expr : Node_Id;
+ Decl : constant Node_Id := Declaration_Node (E);
+ Typ : constant Entity_Id := Etype (E);
+
+ begin
+ if Present (Addr) then
+ Expr := Expression (Addr);
+
+ -- If we have no initialization of any kind, then we don't
+ -- need to place any restrictions on the address clause, because
+ -- the object will be elaborated after the address clause is
+ -- evaluated. This happens if the declaration has no initial
+ -- expression, or the type has no implicit initialization, or
+ -- the object is imported.
+
+ -- The same holds for all initialized scalar types and all
+ -- access types. Packed bit arrays of size up to 64 are
+ -- represented using a modular type with an initialization
+ -- (to zero) and can be processed like other initialized
+ -- scalar types.
+
+ -- If the type is controlled, code to attach the object to a
+ -- finalization chain is generated at the point of declaration,
+ -- and therefore the elaboration of the object cannot be delayed:
+ -- the address expression must be a constant.
+
+ if (No (Expression (Decl))
+ and then not Controlled_Type (Typ)
+ and then
+ (not Has_Non_Null_Base_Init_Proc (Typ)
+ or else Is_Imported (E)))
+
+ or else
+ (Present (Expression (Decl))
+ and then Is_Scalar_Type (Typ))
+
+ or else
+ Is_Access_Type (Typ)
+
+ or else
+ (Is_Bit_Packed_Array (Typ)
+ and then
+ Is_Modular_Integer_Type (Packed_Array_Type (Typ)))
+ then
+ null;
+
+ -- Otherwise, we require the address clause to be constant
+ -- because the call to the initialization procedure (or the
+ -- attach code) has to happen at the point of the declaration.
+
+ else
+ Check_Constant_Address_Clause (Expr, E);
+ Set_Has_Delayed_Freeze (E, False);
+ end if;
+
+ if not Error_Posted (Expr)
+ and then not Controlled_Type (Typ)
+ then
+ Warn_Overlay (Expr, Typ, Name (Addr));
+ end if;
+ end if;
+ end Check_Address_Clause;
+
-----------------------------
-- Check_Compile_Time_Size --
-----------------------------
function Static_Discriminated_Components (T : Entity_Id) return Boolean;
-- If T is a constrained subtype, its size is not known if any of its
-- discriminant constraints is not static and it is not a null record.
- -- The test is conservative and doesn't check that the components are
+ -- The test is conservative and doesn't check that the components are
-- in fact constrained by non-static discriminant values. Could be made
-- more precise ???
return not Is_Generic_Type (T);
elsif Is_Array_Type (T) then
-
if Ekind (T) = E_String_Literal_Subtype then
Set_Small_Size (Component_Size (T) * String_Literal_Length (T));
return True;
begin
Index := First_Index (T);
-
while Present (Index) loop
if Nkind (Index) = N_Range then
Get_Index_Bounds (Index, Low, High);
end if;
elsif Is_Record_Type (T) then
+
+ -- A class-wide type is never considered to have a known size
+
if Is_Class_Wide_Type (T) then
return False;
- elsif T /= Base_Type (T) then
- return Size_Known_At_Compile_Time (Base_Type (T))
- and then Static_Discriminated_Components (T);
+ -- A subtype of a variant record must not have non-static
+ -- discriminanted components.
+
+ elsif T /= Base_Type (T)
+ and then not Static_Discriminated_Components (T)
+ then
+ return False;
-- Don't do any recursion on type with error posted, since
-- we may have a malformed type that leads us into a loop
elsif Error_Posted (T) then
return False;
+ end if;
- else
- declare
- Packed_Size_Known : Boolean := Is_Packed (T);
- Packed_Size : Uint := Uint_0;
+ -- Now look at the components of the record
- begin
- -- Test for variant part present
-
- if Has_Discriminants (T)
- and then Present (Parent (T))
- and then Nkind (Parent (T)) = N_Full_Type_Declaration
- and then Nkind (Type_Definition (Parent (T))) =
- N_Record_Definition
- and then not Null_Present (Type_Definition (Parent (T)))
- and then Present (Variant_Part
- (Component_List (Type_Definition (Parent (T)))))
+ declare
+ -- The following two variables are used to keep track of
+ -- the size of packed records if we can tell the size of
+ -- the packed record in the front end. Packed_Size_Known
+ -- is True if so far we can figure out the size. It is
+ -- initialized to True for a packed record, unless the
+ -- record has discriminants. The reason we eliminate the
+ -- discriminated case is that we don't know the way the
+ -- back end lays out discriminated packed records. If
+ -- Packed_Size_Known is True, then Packed_Size is the
+ -- size in bits so far.
+
+ Packed_Size_Known : Boolean :=
+ Is_Packed (T)
+ and then not Has_Discriminants (T);
+
+ Packed_Size : Uint := Uint_0;
+
+ begin
+ -- Test for variant part present
+
+ if Has_Discriminants (T)
+ and then Present (Parent (T))
+ and then Nkind (Parent (T)) = N_Full_Type_Declaration
+ and then Nkind (Type_Definition (Parent (T))) =
+ N_Record_Definition
+ and then not Null_Present (Type_Definition (Parent (T)))
+ and then Present (Variant_Part
+ (Component_List (Type_Definition (Parent (T)))))
+ then
+ -- If variant part is present, and type is unconstrained,
+ -- then we must have defaulted discriminants, or a size
+ -- clause must be present for the type, or else the size
+ -- is definitely not known at compile time.
+
+ if not Is_Constrained (T)
+ and then
+ No (Discriminant_Default_Value
+ (First_Discriminant (T)))
+ and then Unknown_Esize (T)
then
- -- If variant part is present, and type is unconstrained,
- -- then we must have defaulted discriminants, or a size
- -- clause must be present for the type, or else the size
- -- is definitely not known at compile time.
-
- if not Is_Constrained (T)
- and then
- No (Discriminant_Default_Value
- (First_Discriminant (T)))
- and then Unknown_Esize (T)
- then
- return False;
- else
- -- We do not know the packed size, it is too much
- -- trouble to figure it out.
+ return False;
+ end if;
+ end if;
+ -- Loop through components
+
+ Comp := First_Entity (T);
+ while Present (Comp) loop
+ if Ekind (Comp) = E_Component
+ or else
+ Ekind (Comp) = E_Discriminant
+ then
+ Ctyp := Etype (Comp);
+
+ -- We do not know the packed size if there is a
+ -- component clause present (we possibly could,
+ -- but this would only help in the case of a record
+ -- with partial rep clauses. That's because in the
+ -- case of full rep clauses, the size gets figured
+ -- out anyway by a different circuit).
+
+ if Present (Component_Clause (Comp)) then
Packed_Size_Known := False;
end if;
- end if;
- Comp := First_Entity (T);
-
- while Present (Comp) loop
- if Ekind (Comp) = E_Component
- or else
- Ekind (Comp) = E_Discriminant
+ -- We need to identify a component that is an array
+ -- where the index type is an enumeration type with
+ -- non-standard representation, and some bound of the
+ -- type depends on a discriminant.
+
+ -- This is because gigi computes the size by doing a
+ -- substituation of the appropriate discriminant value
+ -- in the size expression for the base type, and gigi
+ -- is not clever enough to evaluate the resulting
+ -- expression (which involves a call to rep_to_pos)
+ -- at compile time.
+
+ -- It would be nice if gigi would either recognize that
+ -- this expression can be computed at compile time, or
+ -- alternatively figured out the size from the subtype
+ -- directly, where all the information is at hand ???
+
+ if Is_Array_Type (Etype (Comp))
+ and then Present (Packed_Array_Type (Etype (Comp)))
then
- Ctyp := Etype (Comp);
+ declare
+ Ocomp : constant Entity_Id :=
+ Original_Record_Component (Comp);
+ OCtyp : constant Entity_Id := Etype (Ocomp);
+ Ind : Node_Id;
+ Indtyp : Entity_Id;
+ Lo, Hi : Node_Id;
- if Present (Component_Clause (Comp)) then
- Packed_Size_Known := False;
- end if;
+ begin
+ Ind := First_Index (OCtyp);
+ while Present (Ind) loop
+ Indtyp := Etype (Ind);
+
+ if Is_Enumeration_Type (Indtyp)
+ and then Has_Non_Standard_Rep (Indtyp)
+ then
+ Lo := Type_Low_Bound (Indtyp);
+ Hi := Type_High_Bound (Indtyp);
+
+ if Is_Entity_Name (Lo)
+ and then
+ Ekind (Entity (Lo)) = E_Discriminant
+ then
+ return False;
+
+ elsif Is_Entity_Name (Hi)
+ and then
+ Ekind (Entity (Hi)) = E_Discriminant
+ then
+ return False;
+ end if;
+ end if;
- if not Size_Known (Ctyp) then
- return False;
+ Next_Index (Ind);
+ end loop;
+ end;
+ end if;
+
+ -- Clearly size of record is not known if the size of
+ -- one of the components is not known.
+
+ if not Size_Known (Ctyp) then
+ return False;
+ end if;
+
+ -- Accumulate packed size if possible
+
+ if Packed_Size_Known then
- elsif Packed_Size_Known then
+ -- We can only deal with elementary types, since for
+ -- non-elementary components, alignment enters into
+ -- the picture, and we don't know enough to handle
+ -- proper alignment in this context. Packed arrays
+ -- count as elementary if the representation is a
+ -- modular type.
+ if Is_Elementary_Type (Ctyp)
+ or else (Is_Array_Type (Ctyp)
+ and then
+ Present (Packed_Array_Type (Ctyp))
+ and then
+ Is_Modular_Integer_Type
+ (Packed_Array_Type (Ctyp)))
+ then
-- If RM_Size is known and static, then we can
-- keep accumulating the packed size.
if RM_Size (Ctyp) = Uint_0 then
Packed_Size_Known := False;
- end if;
- Packed_Size :=
- Packed_Size + RM_Size (Ctyp);
+ -- Normal case where we can keep accumulating
+ -- the packed array size.
+
+ else
+ Packed_Size := Packed_Size + RM_Size (Ctyp);
+ end if;
-- If we have a field whose RM_Size is not known
-- then we can't figure out the packed size here.
else
Packed_Size_Known := False;
end if;
+
+ -- If we have a non-elementary type we can't figure
+ -- out the packed array size (alignment issues).
+
+ else
+ Packed_Size_Known := False;
end if;
end if;
+ end if;
- Next_Entity (Comp);
- end loop;
+ Next_Entity (Comp);
+ end loop;
- if Packed_Size_Known then
- Set_Small_Size (Packed_Size);
- end if;
+ if Packed_Size_Known then
+ Set_Small_Size (Packed_Size);
+ end if;
- return True;
- end;
- end if;
+ return True;
+ end;
else
return False;
-------------------------------------
function Static_Discriminated_Components
- (T : Entity_Id)
- return Boolean
+ (T : Entity_Id) return Boolean
is
Constraint : Elmt_Id;
and then Present (First_Component (T))
then
Constraint := First_Elmt (Discriminant_Constraint (T));
-
while Present (Constraint) loop
if not Compile_Time_Known_Value (Node (Constraint)) then
return False;
while Present (Comp) loop
if not Is_Type (Comp)
and then (Strict_Alignment (Etype (Comp))
- or else Is_Aliased (Comp))
+ or else Is_Aliased (Comp))
then
Set_Strict_Alignment (E);
return;
end if;
return;
-
end if;
end if;
end loop;
end Check_Unsigned_Type;
+ -----------------------------
+ -- Expand_Atomic_Aggregate --
+ -----------------------------
+
+ procedure Expand_Atomic_Aggregate (E : Entity_Id; Typ : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (E);
+ New_N : Node_Id;
+ Temp : Entity_Id;
+
+ begin
+ if (Nkind (Parent (E)) = N_Object_Declaration
+ or else Nkind (Parent (E)) = N_Assignment_Statement)
+ and then Comes_From_Source (Parent (E))
+ and then Nkind (E) = N_Aggregate
+ then
+ Temp :=
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('T'));
+
+ New_N :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_definition => New_Occurrence_Of (Typ, Loc),
+ Expression => Relocate_Node (E));
+ Insert_Before (Parent (E), New_N);
+ Analyze (New_N);
+
+ Set_Expression (Parent (E), New_Occurrence_Of (Temp, Loc));
+
+ -- To prevent the temporary from being constant-folded (which
+ -- would lead to the same piecemeal assignment on the original
+ -- target) indicate to the back-end that the temporary is a
+ -- variable with real storage. See description of this flag
+ -- in Einfo, and the notes on N_Assignment_Statement and
+ -- N_Object_Declaration in Sinfo.
+
+ Set_Is_True_Constant (Temp, False);
+ end if;
+ end Expand_Atomic_Aggregate;
+
----------------
-- Freeze_All --
----------------
-- should not be recursive, we don't want to analyze those till
-- we are sure that ALL the types are frozen).
+ --------------------
+ -- Freeze_All_Ent --
+ --------------------
+
procedure Freeze_All_Ent
(From : Entity_Id;
After : in out Node_Id)
-- If freeze nodes are present, insert and analyze, and reset
-- cursor for next insertion.
+ -------------------
+ -- Process_Flist --
+ -------------------
+
procedure Process_Flist is
begin
if Is_Non_Empty_List (Flist) then
end if;
end Process_Flist;
+ -- Start or processing for Freeze_All_Ent
+
begin
E := From;
while Present (E) loop
elsif Ekind (E) in Task_Kind
and then
(Nkind (Parent (E)) = N_Task_Type_Declaration
- or else
+ or else
Nkind (Parent (E)) = N_Single_Task_Declaration)
then
New_Scope (E);
declare
Prim_List : constant Elist_Id :=
Primitive_Operations (Etype (E));
- Prim : Elmt_Id;
- Subp : Entity_Id;
+
+ Prim : Elmt_Id;
+ Subp : Entity_Id;
begin
Prim := First_Elmt (Prim_List);
Process_Flist;
end if;
+ -- If an incomplete type is still not frozen, this may be
+ -- a premature freezing because of a body declaration that
+ -- follows. Indicate where the freezing took place.
+
+ -- If the freezing is caused by the end of the current
+ -- declarative part, it is a Taft Amendment type, and there
+ -- is no error.
+
+ if not Is_Frozen (E)
+ and then Ekind (E) = E_Incomplete_Type
+ then
+ declare
+ Bod : constant Node_Id := Next (After);
+
+ begin
+ if (Nkind (Bod) = N_Subprogram_Body
+ or else Nkind (Bod) = N_Entry_Body
+ or else Nkind (Bod) = N_Package_Body
+ or else Nkind (Bod) = N_Protected_Body
+ or else Nkind (Bod) = N_Task_Body
+ or else Nkind (Bod) in N_Body_Stub)
+ and then
+ List_Containing (After) = List_Containing (Parent (E))
+ then
+ Error_Msg_Sloc := Sloc (Next (After));
+ Error_Msg_NE
+ ("type& is frozen# before its full declaration",
+ Parent (E), E);
+ end if;
+ end;
+ end if;
+
Next_Entity (E);
end loop;
end Freeze_All_Ent;
-- that require us to build a default expression functions. This is the
-- point at which such functions are constructed (after all types that
-- might be used in such expressions have been frozen).
+
-- We also add finalization chains to access types whose designated
-- types are controlled. This is normally done when freezing the type,
-- but this misses recursive type definitions where the later members
E := From;
while Present (E) loop
-
if Is_Subprogram (E) then
if not Default_Expressions_Processed (E) then
and then Present (Corresponding_Body (Decl))
and then
Nkind (Unit_Declaration_Node (Corresponding_Body (Decl)))
- = N_Subprogram_Renaming_Declaration
+ = N_Subprogram_Renaming_Declaration
then
Build_And_Analyze_Renamed_Body
(Decl, Corresponding_Body (Decl), After);
elsif Ekind (E) in Task_Kind
and then
(Nkind (Parent (E)) = N_Task_Type_Declaration
- or else
+ or else
Nkind (Parent (E)) = N_Single_Task_Declaration)
then
declare
Ent : Entity_Id;
-
begin
Ent := First_Entity (E);
Next_Entity (E);
end loop;
-
end Freeze_All;
-----------------------
Result : in out List_Id)
is
L : constant List_Id := Freeze_Entity (Ent, Loc);
-
begin
if Is_Non_Empty_List (L) then
if Result = No_List then
procedure Freeze_Before (N : Node_Id; T : Entity_Id) is
Freeze_Nodes : constant List_Id := Freeze_Entity (T, Sloc (N));
- F : Node_Id;
-
begin
if Is_Non_Empty_List (Freeze_Nodes) then
- F := First (Freeze_Nodes);
-
- if Present (F) then
- Insert_Actions (N, Freeze_Nodes);
- end if;
+ Insert_Actions (N, Freeze_Nodes);
end if;
end Freeze_Before;
----------------------------
function After_Last_Declaration return Boolean is
- Spec : Node_Id := Parent (Current_Scope);
+ Spec : constant Node_Id := Parent (Current_Scope);
begin
if Nkind (Spec) = N_Package_Specification then
function Process (N : Node_Id) return Traverse_Result;
-- Process routine to apply check to given node.
+ -------------
+ -- Process --
+ -------------
+
function Process (N : Node_Id) return Traverse_Result is
begin
case Nkind (N) is
procedure Freeze_Record_Type (Rec : Entity_Id) is
Comp : Entity_Id;
+ IR : Node_Id;
Junk : Boolean;
ADC : Node_Id;
-- Set True if we find at least one component with a component
-- clause (used to warn about useless Bit_Order pragmas).
+ procedure Check_Itype (Desig : Entity_Id);
+ -- If the component subtype is an access to a constrained subtype
+ -- of an already frozen type, make the subtype frozen as well. It
+ -- might otherwise be frozen in the wrong scope, and a freeze node
+ -- on subtype has no effect.
+
+ -----------------
+ -- Check_Itype --
+ -----------------
+
+ procedure Check_Itype (Desig : Entity_Id) is
+ begin
+ if not Is_Frozen (Desig)
+ and then Is_Frozen (Base_Type (Desig))
+ then
+ Set_Is_Frozen (Desig);
+
+ -- In addition, add an Itype_Reference to ensure that the
+ -- access subtype is elaborated early enough. This cannot
+ -- be done if the subtype may depend on discriminants.
+
+ if Ekind (Comp) = E_Component
+ and then Is_Itype (Etype (Comp))
+ and then not Has_Discriminants (Rec)
+ then
+ IR := Make_Itype_Reference (Sloc (Comp));
+ Set_Itype (IR, Desig);
+
+ if No (Result) then
+ Result := New_List (IR);
+ else
+ Append (IR, Result);
+ end if;
+ end if;
+ end if;
+ end Check_Itype;
+
+ -- Start of processing for Freeze_Record_Type
+
begin
+ -- If this is a subtype of a controlled type, declared without
+ -- a constraint, the _controller may not appear in the component
+ -- list if the parent was not frozen at the point of subtype
+ -- declaration. Inherit the _controller component now.
+
+ if Rec /= Base_Type (Rec)
+ and then Has_Controlled_Component (Rec)
+ then
+ if Nkind (Parent (Rec)) = N_Subtype_Declaration
+ and then Is_Entity_Name (Subtype_Indication (Parent (Rec)))
+ then
+ Set_First_Entity (Rec, First_Entity (Base_Type (Rec)));
+
+ -- If this is an internal type without a declaration, as for a
+ -- record component, the base type may not yet be frozen, and its
+ -- controller has not been created. Add an explicit freeze node
+ -- for the itype, so it will be frozen after the base type.
+
+ elsif Is_Itype (Rec)
+ and then Has_Delayed_Freeze (Base_Type (Rec))
+ and then
+ Nkind (Associated_Node_For_Itype (Rec)) =
+ N_Component_Declaration
+ then
+ Ensure_Freeze_Node (Rec);
+ end if;
+ end if;
+
-- Freeze components and embedded subtypes
Comp := First_Entity (Rec);
-
while Present (Comp) loop
-
if not Is_Type (Comp) then
Freeze_And_Append (Etype (Comp), Loc, Result);
end if;
-- case freeze the subtype mark.
if Is_Class_Wide_Type (Designated_Type (Etype (Comp))) then
-
if Is_Entity_Name (Expression (Alloc)) then
Freeze_And_Append
(Entity (Expression (Alloc)), Loc, Result);
(Entity (Subtype_Mark (Expression (Alloc))),
Loc, Result);
end if;
+
+ elsif Is_Itype (Designated_Type (Etype (Comp))) then
+ Check_Itype (Designated_Type (Etype (Comp)));
+
else
Freeze_And_Append
(Designated_Type (Etype (Comp)), Loc, Result);
end if;
end;
- -- If this is a constrained subtype of an already frozen type,
- -- make the subtype frozen as well. It might otherwise be frozen
- -- in the wrong scope, and a freeze node on subtype has no effect.
-
elsif Is_Access_Type (Etype (Comp))
- and then not Is_Frozen (Designated_Type (Etype (Comp)))
and then Is_Itype (Designated_Type (Etype (Comp)))
- and then Is_Frozen (Base_Type (Designated_Type (Etype (Comp))))
then
- Set_Is_Frozen (Designated_Type (Etype (Comp)));
+ Check_Itype (Designated_Type (Etype (Comp)));
elsif Is_Array_Type (Etype (Comp))
and then Is_Access_Type (Component_Type (Etype (Comp)))
if Ekind (Comp) = E_Component
or else Ekind (Comp) = E_Discriminant
then
- -- Check for error of component clause given for variable
- -- sized type. We have to delay this test till this point,
- -- since the component type has to be frozen for us to know
- -- if it is variable length. We omit this test in a generic
- -- context, it will be applied at instantiation time.
-
declare
CC : constant Node_Id := Component_Clause (Comp);
begin
+ -- Check for error of component clause given for variable
+ -- sized type. We have to delay this test till this point,
+ -- since the component type has to be frozen for us to know
+ -- if it is variable length. We omit this test in a generic
+ -- context, it will be applied at instantiation time.
+
if Present (CC) then
Placed_Component := True;
else
Unplaced_Component := True;
end if;
- end;
- -- If component clause is present, then deal with the
- -- non-default bit order case. We cannot do this before
- -- the freeze point, because there is no required order
- -- for the component clause and the bit_order clause.
+ -- Case of component requires byte alignment
- -- We only do this processing for the base type, and in
- -- fact that's important, since otherwise if there are
- -- record subtypes, we could reverse the bits once for
- -- each subtype, which would be incorrect.
+ if Must_Be_On_Byte_Boundary (Etype (Comp)) then
- if Present (Component_Clause (Comp))
- and then Reverse_Bit_Order (Rec)
- and then Ekind (E) = E_Record_Type
- then
- declare
- CFB : constant Uint := Component_Bit_Offset (Comp);
- CSZ : constant Uint := Esize (Comp);
- CLC : constant Node_Id := Component_Clause (Comp);
- Pos : constant Node_Id := Position (CLC);
- FB : constant Node_Id := First_Bit (CLC);
+ -- Set the enclosing record to also require byte align
- Storage_Unit_Offset : constant Uint :=
- CFB / System_Storage_Unit;
+ Set_Must_Be_On_Byte_Boundary (Rec);
- Start_Bit : constant Uint :=
- CFB mod System_Storage_Unit;
+ -- Check for component clause that is inconsistent
+ -- with the required byte boundary alignment.
- begin
- -- Cases where field goes over storage unit boundary
+ if Present (CC)
+ and then Normalized_First_Bit (Comp) mod
+ System_Storage_Unit /= 0
+ then
+ Error_Msg_N
+ ("component & must be byte aligned",
+ Component_Name (Component_Clause (Comp)));
+ end if;
+ end if;
- if Start_Bit + CSZ > System_Storage_Unit then
+ -- If component clause is present, then deal with the
+ -- non-default bit order case. We cannot do this before
+ -- the freeze point, because there is no required order
+ -- for the component clause and the bit_order clause.
- -- Allow multi-byte field but generate warning
+ -- We only do this processing for the base type, and in
+ -- fact that's important, since otherwise if there are
+ -- record subtypes, we could reverse the bits once for
+ -- each subtype, which would be incorrect.
- if Start_Bit mod System_Storage_Unit = 0
- and then CSZ mod System_Storage_Unit = 0
- then
- Error_Msg_N
- ("multi-byte field specified with non-standard"
- & " Bit_Order?", CLC);
+ if Present (CC)
+ and then Reverse_Bit_Order (Rec)
+ and then Ekind (E) = E_Record_Type
+ then
+ declare
+ CFB : constant Uint := Component_Bit_Offset (Comp);
+ CSZ : constant Uint := Esize (Comp);
+ CLC : constant Node_Id := Component_Clause (Comp);
+ Pos : constant Node_Id := Position (CLC);
+ FB : constant Node_Id := First_Bit (CLC);
+
+ Storage_Unit_Offset : constant Uint :=
+ CFB / System_Storage_Unit;
+
+ Start_Bit : constant Uint :=
+ CFB mod System_Storage_Unit;
+
+ begin
+ -- Cases where field goes over storage unit boundary
- if Bytes_Big_Endian then
+ if Start_Bit + CSZ > System_Storage_Unit then
+
+ -- Allow multi-byte field but generate warning
+
+ if Start_Bit mod System_Storage_Unit = 0
+ and then CSZ mod System_Storage_Unit = 0
+ then
Error_Msg_N
- ("bytes are not reversed "
- & "(component is big-endian)?", CLC);
+ ("multi-byte field specified with non-standard"
+ & " Bit_Order?", CLC);
+
+ if Bytes_Big_Endian then
+ Error_Msg_N
+ ("bytes are not reversed "
+ & "(component is big-endian)?", CLC);
+ else
+ Error_Msg_N
+ ("bytes are not reversed "
+ & "(component is little-endian)?", CLC);
+ end if;
+
+ -- Do not allow non-contiguous field
+
else
Error_Msg_N
- ("bytes are not reversed "
- & "(component is little-endian)?", CLC);
+ ("attempt to specify non-contiguous field"
+ & " not permitted", CLC);
+ Error_Msg_N
+ ("\(caused by non-standard Bit_Order "
+ & "specified)", CLC);
end if;
- -- Do not allow non-contiguous field
+ -- Case where field fits in one storage unit
else
- Error_Msg_N
- ("attempt to specify non-contiguous field"
- & " not permitted", CLC);
- Error_Msg_N
- ("\(caused by non-standard Bit_Order "
- & "specified)", CLC);
- end if;
-
- -- Case where field fits in one storage unit
+ -- Give warning if suspicious component clause
- else
- -- Give warning if suspicious component clause
-
- if Intval (FB) >= System_Storage_Unit then
- Error_Msg_N
- ("?Bit_Order clause does not affect " &
- "byte ordering", Pos);
- Error_Msg_Uint_1 :=
- Intval (Pos) + Intval (FB) / System_Storage_Unit;
- Error_Msg_N
- ("?position normalized to ^ before bit " &
- "order interpreted", Pos);
- end if;
+ if Intval (FB) >= System_Storage_Unit then
+ Error_Msg_N
+ ("?Bit_Order clause does not affect " &
+ "byte ordering", Pos);
+ Error_Msg_Uint_1 :=
+ Intval (Pos) + Intval (FB) /
+ System_Storage_Unit;
+ Error_Msg_N
+ ("?position normalized to ^ before bit " &
+ "order interpreted", Pos);
+ end if;
- -- Here is where we fix up the Component_Bit_Offset
- -- value to account for the reverse bit order.
- -- Some examples of what needs to be done are:
+ -- Here is where we fix up the Component_Bit_Offset
+ -- value to account for the reverse bit order.
+ -- Some examples of what needs to be done are:
- -- First_Bit .. Last_Bit Component_Bit_Offset
- -- old new old new
+ -- First_Bit .. Last_Bit Component_Bit_Offset
+ -- old new old new
- -- 0 .. 0 7 .. 7 0 7
- -- 0 .. 1 6 .. 7 0 6
- -- 0 .. 2 5 .. 7 0 5
- -- 0 .. 7 0 .. 7 0 4
+ -- 0 .. 0 7 .. 7 0 7
+ -- 0 .. 1 6 .. 7 0 6
+ -- 0 .. 2 5 .. 7 0 5
+ -- 0 .. 7 0 .. 7 0 4
- -- 1 .. 1 6 .. 6 1 6
- -- 1 .. 4 3 .. 6 1 3
- -- 4 .. 7 0 .. 3 4 0
+ -- 1 .. 1 6 .. 6 1 6
+ -- 1 .. 4 3 .. 6 1 3
+ -- 4 .. 7 0 .. 3 4 0
- -- The general rule is that the first bit is
- -- is obtained by subtracting the old ending bit
- -- from storage_unit - 1.
+ -- The general rule is that the first bit is
+ -- is obtained by subtracting the old ending bit
+ -- from storage_unit - 1.
- Set_Component_Bit_Offset (Comp,
- (Storage_Unit_Offset * System_Storage_Unit)
- + (System_Storage_Unit - 1)
- - (Start_Bit + CSZ - 1));
+ Set_Component_Bit_Offset
+ (Comp,
+ (Storage_Unit_Offset * System_Storage_Unit) +
+ (System_Storage_Unit - 1) -
+ (Start_Bit + CSZ - 1));
- Set_Normalized_First_Bit (Comp,
- Component_Bit_Offset (Comp) mod System_Storage_Unit);
- end if;
- end;
- end if;
+ Set_Normalized_First_Bit
+ (Comp,
+ Component_Bit_Offset (Comp) mod
+ System_Storage_Unit);
+ end if;
+ end;
+ end if;
+ end;
end if;
Next_Entity (Comp);
-- If this is the record corresponding to a remote type,
-- freeze the remote type here since that is what we are
- -- semantically freeing. This prevents having the freeze node
- -- for that type in an inner scope.
+ -- semantically freezing. This prevents having the freeze
+ -- node for that type in an inner scope.
-- Also, Check for controlled components and unchecked unions.
-- Finally, enforce the restriction that access attributes with
-- a current instance prefix can only apply to limited types.
if Ekind (Rec) = E_Record_Type then
-
if Present (Corresponding_Remote_Type (Rec)) then
Freeze_And_Append
(Corresponding_Remote_Type (Rec), Loc, Result);
end if;
Comp := First_Component (Rec);
-
while Present (Comp) loop
if Has_Controlled_Component (Etype (Comp))
or else (Chars (Comp) /= Name_uParent
-- fields with component clauses, where we must check the size.
-- This is not done till the freeze point, since for fixed-point
-- types, we do not know the size until the type is frozen.
+ -- Similar processing applies to bit packed arrays.
if Is_First_Subtype (Rec) then
Comp := First_Component (Rec);
while Present (Comp) loop
if Present (Component_Clause (Comp))
- and then Is_Fixed_Point_Type (Etype (Comp))
+ and then (Is_Fixed_Point_Type (Etype (Comp))
+ or else
+ Is_Bit_Packed_Array (Etype (Comp)))
then
Check_Size
- (Component_Clause (Comp),
+ (Component_Name (Component_Clause (Comp)),
Etype (Comp),
Esize (Comp),
Junk);
-- Start of processing for Freeze_Entity
begin
- -- Do not freeze if already frozen since we only need one freeze node.
+ -- Do not freeze if already frozen since we only need one freeze node
if Is_Frozen (E) then
return No_List;
-- It is improper to freeze an external entity within a generic
-- because its freeze node will appear in a non-valid context.
- -- ??? We should probably freeze the entity at that point and insert
- -- the freeze node in a proper place but this proper place is not
- -- easy to find, and the proper scope is not easy to restore. For
- -- now, just wait to get out of the generic to freeze ???
+ -- The entity will be frozen in the proper scope after the current
+ -- generic is analyzed.
elsif Inside_A_Generic and then External_Ref_In_Generic (E) then
return No_List;
S := Scope (S);
end loop;
end;
+
+ -- Similarly, an inlined instance body may make reference to global
+ -- entities, but these references cannot be the proper freezing point
+ -- for them, and the the absence of inlining freezing will take place
+ -- in their own scope. Normally instance bodies are analyzed after
+ -- the enclosing compilation, and everything has been frozen at the
+ -- proper place, but with front-end inlining an instance body is
+ -- compiled before the end of the enclosing scope, and as a result
+ -- out-of-order freezing must be prevented.
+
+ elsif Front_End_Inlining
+ and then In_Instance_Body
+ and then Present (Scope (E))
+ then
+ declare
+ S : Entity_Id := Scope (E);
+ begin
+ while Present (S) loop
+ if Is_Generic_Instance (S) then
+ exit;
+ else
+ S := Scope (S);
+ end if;
+ end loop;
+
+ if No (S) then
+ return No_List;
+ end if;
+ end;
end if;
-- Here to freeze the entity
then
Set_Encoded_Interface_Name
(E, Get_Default_External_Name (E));
+
+ -- Special processing for atomic objects appearing in object decls
+
+ elsif Is_Atomic (E)
+ and then Nkind (Parent (E)) = N_Object_Declaration
+ and then Present (Expression (Parent (E)))
+ then
+ declare
+ Expr : constant Node_Id := Expression (Parent (E));
+
+ begin
+ -- If expression is an aggregate, assign to a temporary to
+ -- ensure that the actual assignment is done atomically rather
+ -- than component-wise (the assignment to the temp may be done
+ -- component-wise, but that is harmless.
+
+ if Nkind (Expr) = N_Aggregate then
+ Expand_Atomic_Aggregate (Expr, Etype (E));
+
+ -- If the expression is a reference to a record or array
+ -- object entity, then reset Is_True_Constant to False so
+ -- that the compiler will not optimize away the intermediate
+ -- object, which we need in this case for the same reason
+ -- (to ensure that the actual assignment is atomic, rather
+ -- than component-wise).
+
+ elsif Is_Entity_Name (Expr)
+ and then (Is_Record_Type (Etype (Expr))
+ or else
+ Is_Array_Type (Etype (Expr)))
+ then
+ Set_Is_True_Constant (Entity (Expr), False);
+ end if;
+ end;
end if;
-- For a subprogram, freeze all parameter types and also the return
- -- type (RM 13.14(13)). However skip this for internal subprograms.
+ -- type (RM 13.14(14)). However skip this for internal subprograms.
-- This is also the point where any extra formal parameters are
-- created since we now know whether the subprogram will use
-- a foreign convention.
if Is_Subprogram (E) then
-
if not Is_Internal (E) then
-
declare
- F_Type : Entity_Id;
+ F_Type : Entity_Id;
+ Warn_Node : Node_Id;
function Is_Fat_C_Ptr_Type (T : Entity_Id) return Boolean;
-- Determines if given type entity is a fat pointer type
-- Loop through formals
Formal := First_Formal (E);
-
while Present (Formal) loop
-
F_Type := Etype (Formal);
Freeze_And_Append (F_Type, Loc, Result);
-- an artifact of our need to regard the end of an
-- instantiation as a freeze point. Otherwise it is
-- a definite error.
+
-- and then not Is_Wrapper_Package (Current_Scope) ???
if In_Instance then
-- Check bad use of fat C pointer
- if Is_Fat_C_Ptr_Type (F_Type) then
+ if Warn_On_Export_Import and then
+ Is_Fat_C_Ptr_Type (F_Type)
+ then
Error_Msg_Qual_Level := 1;
Error_Msg_N
("?type of & does not correspond to C pointer",
and then not Is_Imported (E)
and then Is_Array_Type (F_Type)
and then not Is_Constrained (F_Type)
+ and then Warn_On_Export_Import
then
Error_Msg_Qual_Level := 1;
- Error_Msg_N
+
+ -- If this is an inherited operation, place the
+ -- warning on the derived type declaration, rather
+ -- than on the original subprogram.
+
+ if Nkind (Original_Node (Parent (E))) =
+ N_Full_Type_Declaration
+ then
+ Warn_Node := Parent (E);
+
+ if Formal = First_Formal (E) then
+ Error_Msg_NE
+ ("?in inherited operation&!", Warn_Node, E);
+ end if;
+ else
+ Warn_Node := Formal;
+ end if;
+
+ Error_Msg_NE
("?type of argument& is unconstrained array",
- Formal);
- Error_Msg_N
+ Warn_Node, Formal);
+ Error_Msg_NE
("?foreign caller must pass bounds explicitly",
- Formal);
+ Warn_Node, Formal);
Error_Msg_Qual_Level := 0;
end if;
if Ekind (E) = E_Function then
Freeze_And_Append (Etype (E), Loc, Result);
- if Is_Fat_C_Ptr_Type (Etype (E)) then
+ if Warn_On_Export_Import
+ and then Is_Fat_C_Ptr_Type (Etype (E))
+ then
Error_Msg_N
("?return type of& does not correspond to C pointer",
E);
and then not Is_Constrained (Etype (E))
and then not Is_Imported (E)
and then Convention (E) in Foreign_Convention
+ and then Warn_On_Export_Import
then
Error_Msg_N
- ("foreign convention function may not " &
+ ("?foreign convention function& should not " &
"return unconstrained array", E);
end if;
end if;
Freeze_And_Append (Etype (E), Loc, Result);
end if;
- -- For object created by object declaration, perform required
- -- categorization (preelaborate and pure) checks. Defer these
- -- checks to freeze time since pragma Import inhibits default
- -- initialization and thus pragma Import affects these checks.
+ -- Special processing for objects created by object declaration
if Nkind (Declaration_Node (E)) = N_Object_Declaration then
+
+ -- For object created by object declaration, perform required
+ -- categorization (preelaborate and pure) checks. Defer these
+ -- checks to freeze time since pragma Import inhibits default
+ -- initialization and thus pragma Import affects these checks.
+
Validate_Object_Declaration (Declaration_Node (E));
+
+ -- If there is an address clause, check it is valid
+
+ Check_Address_Clause (E);
+
+ -- For imported objects, set Is_Public unless there is also
+ -- an address clause, which means that there is no external
+ -- symbol needed for the Import (Is_Public may still be set
+ -- for other unrelated reasons). Note that we delayed this
+ -- processing till freeze time so that we can be sure not
+ -- to set the flag if there is an address clause. If there
+ -- is such a clause, then the only purpose of the import
+ -- pragma is to suppress implicit initialization.
+
+ if Is_Imported (E)
+ and then not Present (Address_Clause (E))
+ then
+ Set_Is_Public (E);
+ end if;
end if;
-- Check that a constant which has a pragma Volatile[_Components]
-- inherited the indication from elsewhere (e.g. an address
-- clause, which is not good enough in RM terms!)
- if Present (Get_Rep_Pragma (E, Name_Atomic)) or else
- Present (Get_Rep_Pragma (E, Name_Atomic_Components)) or else
- Present (Get_Rep_Pragma (E, Name_Volatile)) or else
- Present (Get_Rep_Pragma (E, Name_Volatile_Components))
+ if Present (Get_Rep_Pragma (E, Name_Atomic))
+ or else
+ Present (Get_Rep_Pragma (E, Name_Atomic_Components))
then
Error_Msg_N
- ("stand alone atomic/volatile constant must be imported",
- E);
+ ("stand alone atomic constant must be " &
+ "imported ('R'M 'C.6(13))", E);
+
+ elsif Present (Get_Rep_Pragma (E, Name_Volatile))
+ or else
+ Present (Get_Rep_Pragma (E, Name_Volatile_Components))
+ then
+ Error_Msg_N
+ ("stand alone volatile constant must be " &
+ "imported ('R'M 'C.6(13))", E);
end if;
end if;
Freeze_And_Append (Atype, Loc, Result);
-- Otherwise freeze the base type of the entity before
- -- freezing the entity itself, (RM 13.14(14)).
+ -- freezing the entity itself, (RM 13.14(15)).
elsif E /= Base_Type (E) then
Freeze_And_Append (Base_Type (E), Loc, Result);
end if;
- -- For a derived type, freeze its parent type first (RM 13.14(14))
+ -- For a derived type, freeze its parent type first (RM 13.14(15))
elsif Is_Derived_Type (E) then
Freeze_And_Append (Etype (E), Loc, Result);
end if;
-- For array type, freeze index types and component type first
- -- before freezing the array (RM 13.14(14)).
+ -- before freezing the array (RM 13.14(15)).
if Is_Array_Type (E) then
declare
- Ctyp : constant Entity_Id := Component_Type (E);
+ Ctyp : constant Entity_Id := Component_Type (E);
+ Pnod : Node_Id;
Non_Standard_Enum : Boolean := False;
-- Set true if any of the index types is an enumeration
Set_Component_Size (Base_Type (E), Csiz);
+ -- Check for base type of 8,16,32 bits, where the
+ -- subtype has a length one less than the base type
+ -- and is unsigned (e.g. Natural subtype of Integer)
+
+ -- In such cases, if a component size was not set
+ -- explicitly, then generate a warning.
+
+ if Has_Pragma_Pack (E)
+ and then not Has_Component_Size_Clause (E)
+ and then
+ (Csiz = 7 or else Csiz = 15 or else Csiz = 31)
+ and then Esize (Base_Type (Ctyp)) = Csiz + 1
+ then
+ Error_Msg_Uint_1 := Csiz;
+ Pnod :=
+ Get_Rep_Pragma (First_Subtype (E), Name_Pack);
+
+ if Present (Pnod) then
+ Error_Msg_N
+ ("pragma Pack causes component size to be ^?",
+ Pnod);
+ Error_Msg_N
+ ("\use Component_Size to set desired value",
+ Pnod);
+ end if;
+ end if;
+
-- Actual packing is not needed for 8,16,32,64
-- Also not needed for 24 if alignment is 1
end if;
end if;
+ -- For bit-packed arrays, check the size
+
+ if Is_Bit_Packed_Array (E)
+ and then Known_Esize (E)
+ then
+ declare
+ Discard : Boolean;
+ SizC : constant Node_Id := Size_Clause (E);
+
+ begin
+ -- It is not clear if it is possible to have no size
+ -- clause at this stage, but this is not worth worrying
+ -- about. Post the error on the entity name in the size
+ -- clause if present, else on the type entity itself.
+
+ if Present (SizC) then
+ Check_Size (Name (SizC), E, Esize (E), Discard);
+ else
+ Check_Size (E, E, Esize (E), Discard);
+ end if;
+ end;
+ end if;
+
-- Check one common case of a size given where the array
-- needs to be packed, but was not so the size cannot be
-- honored. This would of course be caught by the backend,
-- we can give a better error message in those cases that
-- we do catch with the circuitry here.
- if Present (Size_Clause (E))
- and then Known_Static_Esize (E)
- and then not Has_Pragma_Pack (E)
- and then Number_Dimensions (E) = 1
- and then not Has_Component_Size_Clause (E)
- and then Known_Static_Component_Size (E)
- then
- declare
- Lo, Hi : Node_Id;
- Ctyp : constant Entity_Id := Component_Type (E);
+ declare
+ Lo, Hi : Node_Id;
+ Ctyp : constant Entity_Id := Component_Type (E);
- begin
+ begin
+ if Present (Size_Clause (E))
+ and then Known_Static_Esize (E)
+ and then not Is_Bit_Packed_Array (E)
+ and then not Has_Pragma_Pack (E)
+ and then Number_Dimensions (E) = 1
+ and then not Has_Component_Size_Clause (E)
+ and then Known_Static_Esize (Ctyp)
+ then
Get_Index_Bounds (First_Index (E), Lo, Hi);
if Compile_Time_Known_Value (Lo)
and then RM_Size (Ctyp) < 64
then
declare
- Lov : constant Uint := Expr_Value (Lo);
- Hiv : constant Uint := Expr_Value (Hi);
- Len : constant Uint :=
- UI_Max (Uint_0, Hiv - Lov + 1);
+ Lov : constant Uint := Expr_Value (Lo);
+ Hiv : constant Uint := Expr_Value (Hi);
+ Len : constant Uint :=
+ UI_Max (Uint_0, Hiv - Lov + 1);
+ Rsiz : constant Uint := RM_Size (Ctyp);
+
+ -- What we are looking for here is the situation
+ -- where the Esize given would be exactly right
+ -- if there was a pragma Pack (resulting in the
+ -- component size being the same as the RM_Size).
+ -- Furthermore, the component type size must be
+ -- an odd size (not a multiple of storage unit)
begin
- if Esize (E) < Len * Component_Size (E)
- and then Esize (E) = Len * RM_Size (Ctyp)
+ if Esize (E) = Len * Rsiz
+ and then Rsiz mod System_Storage_Unit /= 0
then
Error_Msg_NE
("size given for& too small",
end if;
end;
end if;
- end;
- end if;
+ end if;
+ end;
-- If any of the index types was an enumeration type with
-- a non-standard rep clause, then we indicate that the
Set_Has_Non_Standard_Rep (Base_Type (E));
Set_Is_Packed (Base_Type (E));
end if;
- end;
- Set_Component_Alignment_If_Not_Set (E);
+ Set_Component_Alignment_If_Not_Set (E);
- -- If the array is packed, we must create the packed array
- -- type to be used to actually implement the type. This is
- -- only needed for real array types (not for string literal
- -- types, since they are present only for the front end).
+ -- If the array is packed, we must create the packed array
+ -- type to be used to actually implement the type. This is
+ -- only needed for real array types (not for string literal
+ -- types, since they are present only for the front end).
- if Is_Packed (E)
- and then Ekind (E) /= E_String_Literal_Subtype
- then
- Create_Packed_Array_Type (E);
- Freeze_And_Append (Packed_Array_Type (E), Loc, Result);
+ if Is_Packed (E)
+ and then Ekind (E) /= E_String_Literal_Subtype
+ then
+ Create_Packed_Array_Type (E);
+ Freeze_And_Append (Packed_Array_Type (E), Loc, Result);
- -- Size information of packed array type is copied to the
- -- array type, since this is really the representation.
+ -- Size information of packed array type is copied to the
+ -- array type, since this is really the representation.
- Set_Size_Info (E, Packed_Array_Type (E));
- Set_RM_Size (E, RM_Size (Packed_Array_Type (E)));
- end if;
+ Set_Size_Info (E, Packed_Array_Type (E));
+ Set_RM_Size (E, RM_Size (Packed_Array_Type (E)));
+ end if;
- -- For a class wide type, the corresponding specific type is
- -- frozen as well (RM 13.14(14))
+ -- For non-packed arrays set the alignment of the array
+ -- to the alignment of the component type if it is unknown.
+ -- Skip this in the atomic case, since atomic arrays may
+ -- need larger alignments.
+
+ if not Is_Packed (E)
+ and then Unknown_Alignment (E)
+ and then Known_Alignment (Ctyp)
+ and then Known_Static_Component_Size (E)
+ and then Known_Static_Esize (Ctyp)
+ and then Esize (Ctyp) = Component_Size (E)
+ and then not Is_Atomic (E)
+ then
+ Set_Alignment (E, Alignment (Component_Type (E)));
+ end if;
+ end;
+
+ -- For a class-wide type, the corresponding specific type is
+ -- frozen as well (RM 13.14(15))
elsif Is_Class_Wide_Type (E) then
Freeze_And_Append (Root_Type (E), Loc, Result);
if Is_Itype (E)
and then Is_Compilation_Unit (Scope (E))
then
-
declare
- Ref : Node_Id := Make_Itype_Reference (Loc);
+ Ref : constant Node_Id := Make_Itype_Reference (Loc);
begin
Set_Itype (Ref, E);
end;
end if;
- -- For record (sub)type, freeze all the component types (RM
- -- 13.14(14). We test for E_Record_(sub)Type here, rather than
+ -- The equivalent type associated with a class-wide subtype
+ -- needs to be frozen to ensure that its layout is done.
+ -- Class-wide subtypes are currently only frozen on targets
+ -- requiring front-end layout (see New_Class_Wide_Subtype
+ -- and Make_CW_Equivalent_Type in exp_util.adb).
+
+ if Ekind (E) = E_Class_Wide_Subtype
+ and then Present (Equivalent_Type (E))
+ then
+ Freeze_And_Append (Equivalent_Type (E), Loc, Result);
+ end if;
+
+ -- For a record (sub)type, freeze all the component types (RM
+ -- 13.14(15). We test for E_Record_(sub)Type here, rather than
-- using Is_Record_Type, because we don't want to attempt the
-- freeze for the case of a private type with record extension
-- (we will do that later when the full type is frozen).
-- end of a scope (or within the scope of the private type),
-- the partial and full views will have been swapped, the
-- full view appears first in the entity chain and the swapping
- -- mechanism enusres that the pointers are properly set (on
+ -- mechanism ensures that the pointers are properly set (on
-- scope exit).
-- If we encounter the partial view before the full view
Check_Debug_Info_Needed (E);
-- Otherwise freeze full view and patch the pointers
+ -- so that the freeze node will elaborate both views
+ -- in the back-end.
else
- if Is_Private_Type (Full_View (E))
- and then Present (Underlying_Full_View (Full_View (E)))
- then
- Freeze_And_Append
- (Underlying_Full_View (Full_View (E)), Loc, Result);
- end if;
+ declare
+ Full : constant Entity_Id := Full_View (E);
+
+ begin
+ if Is_Private_Type (Full)
+ and then Present (Underlying_Full_View (Full))
+ then
+ Freeze_And_Append
+ (Underlying_Full_View (Full), Loc, Result);
+ end if;
- Freeze_And_Append (Full_View (E), Loc, Result);
+ Freeze_And_Append (Full, Loc, Result);
- if Has_Delayed_Freeze (E) then
- F_Node := Freeze_Node (Full_View (E));
+ if Has_Delayed_Freeze (E) then
+ F_Node := Freeze_Node (Full);
- if Present (F_Node) then
- Set_Freeze_Node (E, F_Node);
- Set_Entity (F_Node, E);
- else
- -- {Incomplete,Private}_Subtypes
- -- with Full_Views constrained by discriminants
+ if Present (F_Node) then
+ Set_Freeze_Node (E, F_Node);
+ Set_Entity (F_Node, E);
- Set_Has_Delayed_Freeze (E, False);
- Set_Freeze_Node (E, Empty);
+ else
+ -- {Incomplete,Private}_Subtypes
+ -- with Full_Views constrained by discriminants
+
+ Set_Has_Delayed_Freeze (E, False);
+ Set_Freeze_Node (E, Empty);
+ end if;
end if;
- end if;
+ end;
Check_Debug_Info_Needed (E);
end if;
if Is_Fixed_Point_Type (E) then
Freeze_Fixed_Point_Type (E);
+ -- Some error checks required for ordinary fixed-point type.
+ -- Defer these till the freeze-point since we need the small
+ -- and range values. We only do these checks for base types
+
+ if Is_Ordinary_Fixed_Point_Type (E)
+ and then E = Base_Type (E)
+ then
+ if Small_Value (E) < Ureal_2_M_80 then
+ Error_Msg_Name_1 := Name_Small;
+ Error_Msg_N
+ ("`&''%` is too small, minimum is 2.0'*'*(-80)", E);
+
+ elsif Small_Value (E) > Ureal_2_80 then
+ Error_Msg_Name_1 := Name_Small;
+ Error_Msg_N
+ ("`&''%` is too large, maximum is 2.0'*'*80", E);
+ end if;
+
+ if Expr_Value_R (Type_Low_Bound (E)) < Ureal_M_10_36 then
+ Error_Msg_Name_1 := Name_First;
+ Error_Msg_N
+ ("`&''%` is too small, minimum is -10.0'*'*36", E);
+ end if;
+
+ if Expr_Value_R (Type_High_Bound (E)) > Ureal_10_36 then
+ Error_Msg_Name_1 := Name_Last;
+ Error_Msg_N
+ ("`&''%` is too large, maximum is 10.0'*'*36", E);
+ end if;
+ end if;
+
elsif Is_Enumeration_Type (E) then
Freeze_Enumeration_Type (E);
if Is_Composite_Type (E) then
if Is_Array_Type (E) then
-
declare
Index : Node_Id := First_Index (E);
Expr1 : Node_Id;
begin
Constraint := First_Elmt (Discriminant_Constraint (E));
-
while Present (Constraint) loop
-
Expr := Node (Constraint);
if Nkind (Expr) = N_Identifier
and then Ekind (Entity (Expr)) = E_Discriminant
Next_Elmt (Constraint);
end loop;
end;
-
end if;
-- AI-117 requires that all new primitives of a tagged type
declare
Prim_List : constant Elist_Id := Primitive_Operations (E);
Prim : Elmt_Id;
-
begin
Prim := First_Elmt (Prim_List);
while Present (Prim) loop
Append (F_Node, Result);
end if;
+ -- A final pass over record types with discriminants. If the type
+ -- has an incomplete declaration, there may be constrained access
+ -- subtypes declared elsewhere, which do not depend on the discrimi-
+ -- nants of the type, and which are used as component types (i.e.
+ -- the full view is a recursive type). The designated types of these
+ -- subtypes can only be elaborated after the type itself, and they
+ -- need an itype reference.
+
+ if Ekind (E) = E_Record_Type
+ and then Has_Discriminants (E)
+ then
+ declare
+ Comp : Entity_Id;
+ IR : Node_Id;
+ Typ : Entity_Id;
+
+ begin
+ Comp := First_Component (E);
+
+ while Present (Comp) loop
+ Typ := Etype (Comp);
+
+ if Ekind (Comp) = E_Component
+ and then Is_Access_Type (Typ)
+ and then Scope (Typ) /= E
+ and then Base_Type (Designated_Type (Typ)) = E
+ and then Is_Itype (Designated_Type (Typ))
+ then
+ IR := Make_Itype_Reference (Sloc (Comp));
+ Set_Itype (IR, Designated_Type (Typ));
+ Append (IR, Result);
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+ end;
+ end if;
end if;
-- When a type is frozen, the first subtype of the type is frozen as
Generate_Subprogram_Descriptor_For_Imported_Subprogram
(E, Result);
end if;
-
end if;
return Result;
and then Esize (Typ) < Standard_Integer_Size
then
Init_Esize (Typ, Standard_Integer_Size);
-
else
Adjust_Esize_For_Alignment (Typ);
end if;
-- subprogram (init proc, or stream subprogram). If so, it returns
-- True, otherwise False.
+ -----------------
+ -- In_Exp_Body --
+ -----------------
+
function In_Exp_Body (N : Node_Id) return Boolean is
P : Node_Id;
P := Defining_Unit_Name (Specification (P));
if Nkind (P) = N_Defining_Identifier
- and then (Chars (P) = Name_uInit_Proc or else
- Chars (P) = Name_uInput or else
- Chars (P) = Name_uOutput or else
- Chars (P) = Name_uRead or else
- Chars (P) = Name_uWrite)
+ and then (Is_Init_Proc (P) or else
+ Is_TSS (P, TSS_Stream_Input) or else
+ Is_TSS (P, TSS_Stream_Output) or else
+ Is_TSS (P, TSS_Stream_Read) or else
+ Is_TSS (P, TSS_Stream_Write))
then
return True;
else
return False;
end if;
end if;
-
end In_Exp_Body;
-- Start of processing for Freeze_Expression
-- Freeze type of expression if not frozen already
- if Nkind (N) in N_Has_Etype
- and then not Is_Frozen (Etype (N))
- then
- Typ := Etype (N);
- else
- Typ := Empty;
+ Typ := Empty;
+
+ if Nkind (N) in N_Has_Etype then
+ if not Is_Frozen (Etype (N)) then
+ Typ := Etype (N);
+
+ -- Base type may be an derived numeric type that is frozen at
+ -- the point of declaration, but first_subtype is still unfrozen.
+
+ elsif not Is_Frozen (First_Subtype (Etype (N))) then
+ Typ := First_Subtype (Etype (N));
+ end if;
end if;
-- For entity name, freeze entity if not frozen already. A special
or else not Comes_From_Source (Entity (N)))
then
Nam := Entity (N);
-
else
Nam := Empty;
end if;
-- expression cannot contain an allocator, so the type is not frozen.
Desig_Typ := Empty;
- case Nkind (N) is
+ case Nkind (N) is
when N_Allocator =>
Desig_Typ := Designated_Type (Etype (N));
when others =>
null;
-
end case;
if Desig_Typ /= Empty
-- If we have an enumeration literal that appears as the
-- choice in the aggregate of an enumeration representation
- -- clause, then freezing does not occur (RM 13.14(9)).
+ -- clause, then freezing does not occur (RM 13.14(10)).
when N_Enumeration_Representation_Clause =>
end if;
if Is_Non_Empty_List (Freeze_Nodes) then
-
if No (Scope_Stack.Table
(Scope_Stack.Last).Pending_Freeze_Actions)
then
In_Default_Expression := False;
- -- Freeze the designated type of an allocator (RM 13.14(12))
+ -- Freeze the designated type of an allocator (RM 13.14(13))
if Present (Desig_Typ) then
Freeze_Before (P, Desig_Typ);
end if;
- -- Freeze type of expression (RM 13.14(9)). Note that we took care of
+ -- Freeze type of expression (RM 13.14(10)). Note that we took care of
-- the enumeration representation clause exception in the loop above.
if Present (Typ) then
Freeze_Before (P, Typ);
end if;
- -- Freeze name if one is present (RM 13.14(10))
+ -- Freeze name if one is present (RM 13.14(11))
if Present (Nam) then
Freeze_Before (P, Nam);
-- Returns size of type with given bounds. Also leaves these
-- bounds set as the current bounds of the Typ.
+ -----------
+ -- Fsize --
+ -----------
+
function Fsize (Lov, Hiv : Ureal) return Nat is
begin
Set_Realval (Lo, Lov);
return Minimum_Size (Typ);
end Fsize;
- -- Start of processing for Freeze_Fixed_Point_Type;
+ -- Start of processing for Freeze_Fixed_Point_Type
begin
-- If Esize of a subtype has not previously been set, set it now
Atype := Ancestor_Subtype (Typ);
if Present (Atype) then
- Set_Size_Info (Typ, Atype);
+ Set_Esize (Typ, Esize (Atype));
else
- Set_Size_Info (Typ, Base_Type (Typ));
+ Set_Esize (Typ, Esize (Base_Type (Typ)));
end if;
end if;
Set_Etype (Rng, Etype (Lo));
- -- Set Esize to calculated size and also set RM_Size
+ -- Set Esize to calculated size if not set already
- Init_Esize (Typ, Actual_Size);
+ if Unknown_Esize (Typ) then
+ Init_Esize (Typ, Actual_Size);
+ end if;
-- Set RM_Size if not already set. If already set, check value
Set_RM_Size (Typ, Minsiz);
end if;
end;
-
end Freeze_Fixed_Point_Type;
------------------
begin
Ensure_Type_Is_SA (Etype (E));
+ -- Reset True_Constant flag, since something strange is going on
+ -- with the scoping here, and our simple value tracing may not
+ -- be sufficient for this indication to be reliable. We kill the
+ -- Constant_Value indication for the same reason.
+
+ Set_Is_True_Constant (E, False);
+ Set_Current_Value (E, Empty);
+
exception
when Cannot_Be_Static =>
end if;
end if;
+ -- Reset the Pure indication on an imported subprogram unless an
+ -- explicit Pure_Function pragma was present. We do this because
+ -- otherwise it is an insidious error to call a non-pure function
+ -- from a pure unit and have calls mysteriously optimized away.
+ -- What happens here is that the Import can bypass the normal
+ -- check to ensure that pure units call only pure subprograms.
+
+ if Is_Imported (E)
+ and then Is_Pure (E)
+ and then not Has_Pragma_Pure_Function (E)
+ then
+ Set_Is_Pure (E, False);
+ end if;
+
-- For non-foreign convention subprograms, this is where we create
-- the extra formals (for accessibility level and constrained bit
-- information). We delay this till the freeze point precisely so
if Ekind (E) = E_Procedure
and then Is_Valued_Procedure (E)
and then Convention (E) = Convention_Ada
+ and then Warn_On_Export_Import
then
Error_Msg_N
("?Valued_Procedure has no effect for convention Ada", E);
else
Set_Mechanisms (E);
- -- For foreign conventions, do not permit return of an
+ -- For foreign conventions, warn about return of an
-- unconstrained array.
-- Note: we *do* allow a return by descriptor for the VMS case,
elsif Is_Array_Type (Retype)
and then not Is_Constrained (Retype)
and then Mechanism (E) not in Descriptor_Codes
+ and then Warn_On_Export_Import
then
- Error_Msg_NE
- ("convention for& does not permit returning " &
- "unconstrained array type", E, E);
+ Error_Msg_N
+ ("?foreign convention function& should not return " &
+ "unconstrained array", E);
return;
end if;
end if;
if Is_Exported (E) then
F := First_Formal (E);
while Present (F) loop
- if Present (Default_Value (F)) then
+ if Warn_On_Export_Import
+ and then Present (Default_Value (F))
+ then
Error_Msg_N
("?parameter cannot be defaulted in non-Ada call",
Default_Value (F));
end loop;
end if;
end if;
-
end Freeze_Subprogram;
- -----------------------
- -- Is_Fully_Defined --
- -----------------------
-
- -- Should this be in Sem_Util ???
+ ----------------------
+ -- Is_Fully_Defined --
+ ----------------------
function Is_Fully_Defined (T : Entity_Id) return Boolean is
begin
if Ekind (T) = E_Class_Wide_Type then
return Is_Fully_Defined (Etype (T));
- else
- return not Is_Private_Type (T)
- or else Present (Full_View (Base_Type (T)));
+
+ elsif Is_Array_Type (T) then
+ return Is_Fully_Defined (Component_Type (T));
+
+ elsif Is_Record_Type (T)
+ and not Is_Private_Type (T)
+ then
+ -- Verify that the record type has no components with
+ -- private types without completion.
+
+ declare
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Component (T);
+
+ while Present (Comp) loop
+ if not Is_Fully_Defined (Etype (Comp)) then
+ return False;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+ return True;
+ end;
+
+ else return not Is_Private_Type (T)
+ or else Present (Full_View (Base_Type (T)));
end if;
end Is_Fully_Defined;
or else (Nkind (Dcopy) = N_Attribute_Reference
and then
Attribute_Name (Dcopy) = Name_Null_Parameter)
-
then
-- If there is no default function, we must still do a full
-- context is generic, to avoid anomalies with private types.
if Ekind (Scope (E)) = E_Generic_Package then
- Resolve (Dcopy, Etype (Dcopy));
+ Resolve (Dcopy);
else
Resolve (Dcopy, Etype (Formal));
end if;
Set_Debug_Info_Needed (Corresponding_Record_Type (T));
end if;
end if;
-
end Set_Debug_Info_Needed;
+ ------------------
+ -- Warn_Overlay --
+ ------------------
+
+ procedure Warn_Overlay
+ (Expr : Node_Id;
+ Typ : Entity_Id;
+ Nam : Entity_Id)
+ is
+ Ent : constant Entity_Id := Entity (Nam);
+ -- The object to which the address clause applies.
+
+ Init : Node_Id;
+ Old : Entity_Id := Empty;
+ Decl : Node_Id;
+
+ begin
+ -- No warning if address clause overlay warnings are off
+
+ if not Address_Clause_Overlay_Warnings then
+ return;
+ end if;
+
+ -- No warning if there is an explicit initialization
+
+ Init := Original_Node (Expression (Declaration_Node (Ent)));
+
+ if Present (Init) and then Comes_From_Source (Init) then
+ return;
+ end if;
+
+ -- We only give the warning for non-imported entities of a type
+ -- for which a non-null base init proc is defined (or for access
+ -- types which have implicit null initialization).
+
+ if Present (Expr)
+ and then (Has_Non_Null_Base_Init_Proc (Typ)
+ or else Is_Access_Type (Typ))
+ and then not Is_Imported (Ent)
+ then
+ if Nkind (Expr) = N_Attribute_Reference
+ and then Is_Entity_Name (Prefix (Expr))
+ then
+ Old := Entity (Prefix (Expr));
+
+ elsif Is_Entity_Name (Expr)
+ and then Ekind (Entity (Expr)) = E_Constant
+ then
+ Decl := Declaration_Node (Entity (Expr));
+
+ if Nkind (Decl) = N_Object_Declaration
+ and then Present (Expression (Decl))
+ and then Nkind (Expression (Decl)) = N_Attribute_Reference
+ and then Is_Entity_Name (Prefix (Expression (Decl)))
+ then
+ Old := Entity (Prefix (Expression (Decl)));
+
+ elsif Nkind (Expr) = N_Function_Call then
+ return;
+ end if;
+
+ -- A function call (most likely to To_Address) is probably not
+ -- an overlay, so skip warning. Ditto if the function call was
+ -- inlined and transformed into an entity.
+
+ elsif Nkind (Original_Node (Expr)) = N_Function_Call then
+ return;
+ end if;
+
+ Decl := Next (Parent (Expr));
+
+ -- If a pragma Import follows, we assume that it is for the current
+ -- target of the address clause, and skip the warning.
+
+ if Present (Decl)
+ and then Nkind (Decl) = N_Pragma
+ and then Chars (Decl) = Name_Import
+ then
+ return;
+ end if;
+
+ if Present (Old) then
+ Error_Msg_Node_2 := Old;
+ Error_Msg_N
+ ("default initialization of & may modify &?",
+ Nam);
+ else
+ Error_Msg_N
+ ("default initialization of & may modify overlaid storage?",
+ Nam);
+ end if;
+
+ -- Add friendly warning if initialization comes from a packed array
+ -- component.
+
+ if Is_Record_Type (Typ) then
+ declare
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Component (Typ);
+
+ while Present (Comp) loop
+ if Nkind (Parent (Comp)) = N_Component_Declaration
+ and then Present (Expression (Parent (Comp)))
+ then
+ exit;
+ elsif Is_Array_Type (Etype (Comp))
+ and then Present (Packed_Array_Type (Etype (Comp)))
+ then
+ Error_Msg_NE
+ ("packed array component& will be initialized to zero?",
+ Nam, Comp);
+ exit;
+ else
+ Next_Component (Comp);
+ end if;
+ end loop;
+ end;
+ end if;
+
+ Error_Msg_N
+ ("use pragma Import for & to " &
+ "suppress initialization ('R'M B.1(24))?",
+ Nam);
+ end if;
+ end Warn_Overlay;
+
end Freeze;
OSDN Git Service
