-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
with Exp_Tss; use Exp_Tss;
with Layout; use Layout;
with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
if RM_Size (T) < S then
Error_Msg_Uint_1 := S;
Error_Msg_NE
- ("size for & is too small, minimum is ^",
+ ("size for & too small, minimum allowed is ^",
Size_Clause (T), T);
elsif Unknown_Esize (T) then
and then not Is_Child_Unit (E)
and then not Is_Frozen (E)
then
- New_Scope (E);
+ Push_Scope (E);
Install_Visible_Declarations (E);
Install_Private_Declarations (E);
or else
Nkind (Parent (E)) = N_Single_Task_Declaration)
then
- New_Scope (E);
+ Push_Scope (E);
Freeze_All (First_Entity (E), After);
End_Scope;
function After_Last_Declaration return Boolean is
Spec : constant Node_Id := Parent (Current_Scope);
-
begin
if Nkind (Spec) = N_Package_Specification then
if Present (Private_Declarations (Spec)) then
return Loc >= Sloc (Last (Private_Declarations (Spec)));
-
elsif Present (Visible_Declarations (Spec)) then
return Loc >= Sloc (Last (Visible_Declarations (Spec)));
else
return False;
end if;
-
else
return False;
end if;
-- 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.
+ procedure Check_Itype (Typ : 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. Similarly, if the component subtype is a
+ -- regular (not protected) access to subprogram, set the anonymous
+ -- subprogram type to frozen as well, to prevent an out-of-scope
+ -- freeze node at some eventual point of call. Protected operations
+ -- are handled elsewhere.
-----------------
-- Check_Itype --
-----------------
- procedure Check_Itype (Desig : Entity_Id) is
+ procedure Check_Itype (Typ : Entity_Id) is
+ Desig : constant Entity_Id := Designated_Type (Typ);
+
begin
if not Is_Frozen (Desig)
and then Is_Frozen (Base_Type (Desig))
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.
+ -- 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))
Append (IR, Result);
end if;
end if;
+
+ elsif Ekind (Typ) = E_Anonymous_Access_Subprogram_Type
+ and then Convention (Desig) /= Convention_Protected
+ then
+ Set_Is_Frozen (Desig);
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 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)
if Inside_A_Generic then
null;
- elsif not Size_Known_At_Compile_Time
- (Underlying_Type (Etype (Comp)))
+ elsif not
+ Size_Known_At_Compile_Time
+ (Underlying_Type (Etype (Comp)))
then
Error_Msg_N
("component clause not allowed for variable " &
Set_Must_Be_On_Byte_Boundary (Rec);
- -- Check for component clause that is inconsistent
- -- with the required byte boundary alignment.
+ -- Check for component clause that is inconsistent with
+ -- the required byte boundary alignment.
if Present (CC)
and then Normalized_First_Bit (Comp) mod
end if;
end if;
- -- If component clause is present, then deal with the
- -- non-default bit order case for Ada 95 mode. The required
+ -- If component clause is present, then deal with the non-
+ -- default bit order case for Ada 95 mode. The required
-- processing for Ada 2005 mode is handled separately after
-- processing all components.
end if;
elsif Is_Itype (Designated_Type (Etype (Comp))) then
- Check_Itype (Designated_Type (Etype (Comp)));
+ Check_Itype (Etype (Comp));
else
Freeze_And_Append
elsif Is_Access_Type (Etype (Comp))
and then Is_Itype (Designated_Type (Etype (Comp)))
then
- Check_Itype (Designated_Type (Etype (Comp)));
+ Check_Itype (Etype (Comp));
elsif Is_Array_Type (Etype (Comp))
and then Is_Access_Type (Component_Type (Etype (Comp)))
Next_Component (Comp);
end loop;
end if;
+
+ -- Generate warning for applying C or C++ convention to a record
+ -- with discriminants. This is suppressed for the unchecked union
+ -- case, since the whole point in this case is interface C.
+
+ if Has_Discriminants (E)
+ and then not Is_Unchecked_Union (E)
+ and then not Warnings_Off (E)
+ and then not Warnings_Off (Base_Type (E))
+ and then (Convention (E) = Convention_C
+ or else
+ Convention (E) = Convention_CPP)
+ and then Comes_From_Source (E)
+ then
+ declare
+ Cprag : constant Node_Id := Get_Rep_Pragma (E, Name_Convention);
+ A2 : Node_Id;
+
+ begin
+ if Present (Cprag) then
+ A2 := Next (First (Pragma_Argument_Associations (Cprag)));
+
+ if Convention (E) = Convention_C then
+ Error_Msg_N
+ ("?variant record has no direct equivalent in C", A2);
+ else
+ Error_Msg_N
+ ("?variant record has no direct equivalent in C++", A2);
+ end if;
+
+ Error_Msg_NE
+ ("\?use of convention for type& is dubious", A2, E);
+ end if;
+ end;
+ end if;
end Freeze_Record_Type;
-- Start of processing for Freeze_Entity
-- 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
+ -- for them, and in 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
-- out-of-order freezing must be prevented.
elsif Front_End_Inlining
- and then In_Instance_Body
+ and then In_Instance_Body
and then Present (Scope (Test_E))
then
declare
-- 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.
+ -- component-wise, but that is harmless).
if Nkind (Expr) = N_Aggregate then
Expand_Atomic_Aggregate (Expr, Etype (E));
("(Ada 2005): invalid use of unconstrained tagged"
& " incomplete type", E);
- elsif Ekind (F_Type) = E_Subprogram_Type then
+ -- If the formal is an anonymous_access_to_subprogram
+ -- freeze the subprogram type as well, to prevent
+ -- scope anomalies in gigi, because there is no other
+ -- clear point at which it could be frozen.
+
+ elsif Is_Itype (Etype (Formal))
+ and then Ekind (F_Type) = E_Subprogram_Type
+ then
Freeze_And_Append (F_Type, Loc, Result);
end if;
end if;
elsif Ekind (Etype (E)) = E_Incomplete_Type
and then Is_Tagged_Type (Etype (E))
and then No (Full_View (Etype (E)))
+ and then not Is_Value_Type (Etype (E))
then
Error_Msg_N
("(Ada 2005): invalid use of tagged incomplete type",
else
-- If entity has a type, and it is not a generic unit, then
- -- freeze it first (RM 13.14(10))
+ -- freeze it first (RM 13.14(10)).
if Present (Etype (E))
and then Ekind (E) /= E_Generic_Function
-- 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
+ -- is such a clause, then the only purpose of the Import
-- pragma is to suppress implicit initialization.
if Is_Imported (E)
then
Set_Is_Public (E);
end if;
+
+ -- For convention C objects of an enumeration type, warn if
+ -- the size is not integer size and no explicit size given.
+ -- Skip warning for Boolean, and Character, assume programmer
+ -- expects 8-bit sizes for these cases.
+
+ if (Convention (E) = Convention_C
+ or else
+ Convention (E) = Convention_CPP)
+ and then Is_Enumeration_Type (Etype (E))
+ and then not Is_Character_Type (Etype (E))
+ and then not Is_Boolean_Type (Etype (E))
+ and then Esize (Etype (E)) < Standard_Integer_Size
+ and then not Has_Size_Clause (E)
+ then
+ Error_Msg_Uint_1 := UI_From_Int (Standard_Integer_Size);
+ Error_Msg_N
+ ("?convention C enumeration object has size less than ^",
+ E);
+ Error_Msg_N ("\?use explicit size clause to set size", E);
+ end if;
end if;
-- Check that a constant which has a pragma Volatile[_Components]
- -- or Atomic[_Components] also has a pragma Import (RM C.6(13))
+ -- or Atomic[_Components] also has a pragma Import (RM C.6(13)).
-- Note: Atomic[_Components] also sets Volatile[_Components]
Freeze_And_Append (Atype, Loc, Result);
-- Otherwise freeze the base type of the entity before
- -- freezing the entity itself, (RM 13.14(15)).
+ -- freezing the entity itself (RM 13.14(15)).
elsif E /= Base_Type (E) then
Freeze_And_Append (Base_Type (E), Loc, Result);
Pnod : Node_Id;
Non_Standard_Enum : Boolean := False;
- -- Set true if any of the index types is an enumeration
- -- type with a non-standard representation.
+ -- Set true if any of the index types is an enumeration type
+ -- with a non-standard representation.
begin
Freeze_And_Append (Ctyp, Loc, Result);
Csiz := Uint_0;
end if;
- -- Set component size up to match alignment if
- -- it would otherwise be less than the alignment.
- -- This deals with cases of types whose alignment
- -- exceeds their sizes (padded types).
+ -- Set component size up to match alignment if it
+ -- would otherwise be less than the alignment. This
+ -- deals with cases of types whose alignment exceeds
+ -- their size (padded types).
if Csiz /= 0 then
declare
Set_Component_Size (Base_Type (E), Csiz);
- -- Check for base type of 8,16,32 bits, where the
+ -- 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)
+ -- and is unsigned (e.g. Natural subtype of Integer).
-- In such cases, if a component size was not set
-- explicitly, then generate a warning.
end if;
end if;
- -- Actual packing is not needed for 8,16,32,64
- -- Also not needed for 24 if alignment is 1
+ -- Actual packing is not needed for 8, 16, 32, 64.
+ -- Also not needed for 24 if alignment is 1.
if Csiz = 8
or else Csiz = 16
-- the packing request had no effect, so Is_Packed
-- is reset.
- -- Note: semantically this means that we lose
- -- track of the fact that a derived type inherited
- -- a pack pragma that was non-effective, but that
+ -- Note: semantically this means that we lose track
+ -- of the fact that a derived type inherited a
+ -- pragma Pack that was non-effective, but that
-- seems fine.
-- We regard a Pack pragma as a request to set a
if Unknown_Alignment (E) then
Set_Alignment (E, Alignment (Base_Type (E)));
+ Adjust_Esize_Alignment (E);
end if;
end if;
-- For bit-packed arrays, check the size
if Is_Bit_Packed_Array (E)
- and then Known_Esize (E)
+ and then Known_RM_Size (E)
then
declare
Discard : Boolean;
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 at this stage, but it is not worth worrying
+ -- about. Post 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);
+ Check_Size (Name (SizC), E, RM_Size (E), Discard);
else
- Check_Size (E, E, Esize (E), Discard);
+ Check_Size (E, E, RM_Size (E), Discard);
end if;
end;
end if;
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)
+ -- What we are looking for here is the situation where
+ -- the RM_Size 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 * Rsiz
+ if RM_Size (E) = Len * Rsiz
and then Rsiz mod System_Storage_Unit /= 0
then
Error_Msg_NE
if Ekind (Etype (E)) = E_Incomplete_Type
and then Is_Tagged_Type (Etype (E))
and then No (Full_View (Etype (E)))
+ and then not Is_Value_Type (Etype (E))
then
Error_Msg_N
("(Ada 2005): invalid use of tagged incomplete type", E);
if Ekind (Etyp) = E_Incomplete_Type
and then Is_Tagged_Type (Etyp)
and then No (Full_View (Etyp))
+ and then not Is_Value_Type (Etype (E))
then
Error_Msg_N
("(Ada 2005): invalid use of tagged incomplete type", E);
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);
+ ("`&''%` too small, minimum allowed 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);
+ ("`&''%` too large, maximum allowed 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);
+ ("`&''%` too small, minimum allowed 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);
+ ("`&''%` too large, maximum allowed is 10.0'*'*36", E);
end if;
end if;
-- Now that all types from which E may depend are frozen, see if the
-- size is known at compile time, if it must be unsigned, or if
- -- strict alignent is required
+ -- strict alignment is required
Check_Compile_Time_Size (E);
Check_Unsigned_Type (E);
function In_Exp_Body (N : Node_Id) return Boolean;
-- Given an N_Handled_Sequence_Of_Statements node N, determines whether
-- it is the handled statement sequence of an expander-generated
- -- subprogram (init proc, or stream subprogram). If so, it returns
- -- True, otherwise False.
+ -- subprogram (init proc, stream subprogram, or renaming as body).
+ -- If so, this is not a freezing context.
-----------------
-- In_Exp_Body --
-----------------
function In_Exp_Body (N : Node_Id) return Boolean is
- P : Node_Id;
+ P : Node_Id;
+ Id : Entity_Id;
begin
if Nkind (N) = N_Subprogram_Body then
return False;
else
- P := Defining_Unit_Name (Specification (P));
-
- if Nkind (P) = N_Defining_Identifier
- 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))
+ Id := Defining_Unit_Name (Specification (P));
+
+ if Nkind (Id) = N_Defining_Identifier
+ and then (Is_Init_Proc (Id) or else
+ Is_TSS (Id, TSS_Stream_Input) or else
+ Is_TSS (Id, TSS_Stream_Output) or else
+ Is_TSS (Id, TSS_Stream_Read) or else
+ Is_TSS (Id, TSS_Stream_Write) or else
+ Nkind (Original_Node (P)) =
+ N_Subprogram_Renaming_Declaration)
then
return True;
else
if Actual_Size > 64 then
Error_Msg_Uint_1 := UI_From_Int (Actual_Size);
Error_Msg_N
- ("size required (^) for type& too large, maximum is 64", Typ);
+ ("size required (^) for type& too large, maximum allowed is 64",
+ Typ);
Actual_Size := 64;
end if;
Error_Msg_Uint_1 := RM_Size (Typ);
Error_Msg_Uint_2 := UI_From_Int (Actual_Size);
Error_Msg_NE
- ("size given (^) for type& too small, minimum is ^",
+ ("size given (^) for type& too small, minimum allowed is ^",
Size_Clause (Typ), Typ);
else
Error_Msg_Uint_1 := RM_Size (Typ);
Error_Msg_Uint_2 := Minsiz;
Error_Msg_NE
- ("size given (^) for type& too small, minimum is ^",
+ ("size given (^) for type& too small, minimum allowed is ^",
Size_Clause (Typ), Typ);
end if;
end if;
-- For VMS, descriptor mechanisms for parameters are allowed only
- -- for imported subprograms.
+ -- for imported/exported subprograms. Moreover, the NCA descriptor
+ -- is not allowed for parameters of exported subprograms.
if OpenVMS_On_Target then
- if not Is_Imported (E) then
+ if Is_Exported (E) then
+ F := First_Formal (E);
+ while Present (F) loop
+ if Mechanism (F) = By_Descriptor_NCA then
+ Error_Msg_N
+ ("'N'C'A' descriptor for parameter not permitted", F);
+ Error_Msg_N
+ ("\can only be used for imported subprogram", F);
+ end if;
+
+ Next_Formal (F);
+ end loop;
+
+ elsif not Is_Imported (E) then
F := First_Formal (E);
while Present (F) loop
if Mechanism (F) in Descriptor_Codes then
Error_Msg_N
("descriptor mechanism for parameter not permitted", F);
Error_Msg_N
- ("\can only be used for imported subprogram", F);
+ ("\can only be used for imported/exported subprogram", F);
end if;
Next_Formal (F);
projects / gcc.git / commitdiff