------------------------------------------------------------------------------
+------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
with Exp_Util; use Exp_Util;
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;
-- the designated type. Otherwise freezing the access type does not freeze
-- the designated type.
- procedure Generate_Prim_Op_References (Typ : Entity_Id);
- -- For a tagged type, generate implicit references to its primitive
- -- operations, for source navigation.
-
procedure Process_Default_Expressions
(E : Entity_Id;
After : in out Node_Id);
-- 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.
+ -- Actually the IP call has been moved to the freeze actions
+ -- anyway, so maybe we can relax this restriction???
else
Check_Constant_Address_Clause (Expr, E);
- Set_Has_Delayed_Freeze (E, False);
+
+ -- Has_Delayed_Freeze was set on E when the address clause was
+ -- analyzed. Reset the flag now unless freeze actions were
+ -- attached to it in the mean time.
+
+ if No (Freeze_Node (E)) then
+ Set_Has_Delayed_Freeze (E, False);
+ end if;
end if;
if not Error_Posted (Expr)
if RM_Size (T) < S then
Error_Msg_Uint_1 := S;
Error_Msg_NE
- ("size for & too small, minimum allowed is ^",
+ ("size for& too small, minimum allowed is ^",
Size_Clause (T), T);
elsif Unknown_Esize (T) then
end loop;
end Check_Unsigned_Type;
- -----------------------------
- -- Expand_Atomic_Aggregate --
- -----------------------------
+ -------------------------
+ -- Is_Atomic_Aggregate --
+ -------------------------
- procedure Expand_Atomic_Aggregate (E : Entity_Id; Typ : Entity_Id) is
+ function Is_Atomic_Aggregate
+ (E : Entity_Id;
+ Typ : Entity_Id) return Boolean
+ is
Loc : constant Source_Ptr := Sloc (E);
New_N : Node_Id;
+ Par : 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
+ Par := Parent (E);
+
+ -- Array may be qualified, so find outer context
+
+ if Nkind (Par) = N_Qualified_Expression then
+ Par := Parent (Par);
+ end if;
+
+ if Nkind_In (Par, N_Object_Declaration, N_Assignment_Statement)
+ and then Comes_From_Source (Par)
then
Temp :=
Make_Defining_Identifier (Loc,
Defining_Identifier => Temp,
Object_Definition => New_Occurrence_Of (Typ, Loc),
Expression => Relocate_Node (E));
- Insert_Before (Parent (E), New_N);
+ Insert_Before (Par, 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_Expression (Par, New_Occurrence_Of (Temp, Loc));
+ return True;
- Set_Is_True_Constant (Temp, False);
+ else
+ return False;
end if;
- end Expand_Atomic_Aggregate;
+ end Is_Atomic_Aggregate;
----------------
-- Freeze_All --
-- which is the current instance type can only be applied when the type
-- is limited.
+ procedure Check_Suspicious_Modulus (Utype : Entity_Id);
+ -- Give warning for modulus of 8, 16, 32, or 64 given as an explicit
+ -- integer literal without an explicit corresponding size clause. The
+ -- caller has checked that Utype is a modular integer type.
+
function After_Last_Declaration return Boolean;
-- If Loc is a freeze_entity that appears after the last declaration
-- in the scope, inhibit error messages on late completion.
----------------------------
function After_Last_Declaration return Boolean is
- Spec : constant Node_Id := Parent (Current_Scope);
+ Spec : constant Node_Id := Parent (Current_Scope);
begin
if Nkind (Spec) = N_Package_Specification then
if Present (Private_Declarations (Spec)) then
-- either a tagged type, or a limited record.
if Is_Limited_Type (Rec_Type)
- and then
- (Ada_Version < Ada_05
- or else Is_Tagged_Type (Rec_Type))
+ and then (Ada_Version < Ada_05 or else Is_Tagged_Type (Rec_Type))
then
return;
end if;
end Check_Current_Instance;
+ ------------------------------
+ -- Check_Suspicious_Modulus --
+ ------------------------------
+
+ procedure Check_Suspicious_Modulus (Utype : Entity_Id) is
+ Decl : constant Node_Id := Declaration_Node (Underlying_Type (Utype));
+
+ begin
+ if Nkind (Decl) = N_Full_Type_Declaration then
+ declare
+ Tdef : constant Node_Id := Type_Definition (Decl);
+ begin
+ if Nkind (Tdef) = N_Modular_Type_Definition then
+ declare
+ Modulus : constant Node_Id :=
+ Original_Node (Expression (Tdef));
+ begin
+ if Nkind (Modulus) = N_Integer_Literal then
+ declare
+ Modv : constant Uint := Intval (Modulus);
+ Sizv : constant Uint := RM_Size (Utype);
+
+ begin
+ -- First case, modulus and size are the same. This
+ -- happens if you have something like mod 32, with
+ -- an explicit size of 32, this is for sure a case
+ -- where the warning is given, since it is seems
+ -- very unlikely that someone would want e.g. a
+ -- five bit type stored in 32 bits. It is much
+ -- more likely they wanted a 32-bit type.
+
+ if Modv = Sizv then
+ null;
+
+ -- Second case, the modulus is 32 or 64 and no
+ -- size clause is present. This is a less clear
+ -- case for giving the warning, but in the case
+ -- of 32/64 (5-bit or 6-bit types) these seem rare
+ -- enough that it is a likely error (and in any
+ -- case using 2**5 or 2**6 in these cases seems
+ -- clearer. We don't include 8 or 16 here, simply
+ -- because in practice 3-bit and 4-bit types are
+ -- more common and too many false positives if
+ -- we warn in these cases.
+
+ elsif not Has_Size_Clause (Utype)
+ and then (Modv = Uint_32 or else Modv = Uint_64)
+ then
+ null;
+
+ -- No warning needed
+
+ else
+ return;
+ end if;
+
+ -- If we fall through, give warning
+
+ Error_Msg_Uint_1 := Modv;
+ Error_Msg_N
+ ("?2 '*'*^' may have been intended here",
+ Modulus);
+ end;
+ end if;
+ end;
+ end if;
+ end;
+ end if;
+ end Check_Suspicious_Modulus;
+
------------------------
-- Freeze_Record_Type --
------------------------
Placed_Component : Boolean := False;
-- Set True if we find at least one component with a component
- -- clause (used to warn about useless Bit_Order pragmas).
+ -- clause (used to warn about useless Bit_Order pragmas, and also
+ -- to detect cases where Implicit_Packing may have an effect).
+
+ All_Scalar_Components : Boolean := True;
+ -- Set False if we encounter a component of a non-scalar type
+
+ Scalar_Component_Total_RM_Size : Uint := Uint_0;
+ Scalar_Component_Total_Esize : Uint := Uint_0;
+ -- Accumulates total RM_Size values and total Esize values of all
+ -- scalar components. Used for processing of Implicit_Packing.
function Check_Allocator (N : Node_Id) return Node_Id;
-- If N is an allocator, possibly wrapped in one or more level of
end;
end if;
+ -- Gather data for possible Implicit_Packing later
+
+ if not Is_Scalar_Type (Etype (Comp)) then
+ All_Scalar_Components := False;
+ else
+ Scalar_Component_Total_RM_Size :=
+ Scalar_Component_Total_RM_Size + RM_Size (Etype (Comp));
+ Scalar_Component_Total_Esize :=
+ Scalar_Component_Total_Esize + Esize (Etype (Comp));
+ end if;
+
-- If the component is an Itype with Delayed_Freeze and is either
-- a record or array subtype and its base type has not yet been
-- frozen, we must remove this from the entity list of this
-- 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 Ekind (Rec) = E_Record_Type then
if Present (Corresponding_Remote_Type (Rec)) then
Freeze_And_Append
(Corresponding_Remote_Type (Rec), Loc, Result);
end if;
end;
end if;
+
+ -- See if Size is too small as is (and implicit packing might help)
+
+ if not Is_Packed (Rec)
+
+ -- No implicit packing if even one component is explicitly placed
+
+ and then not Placed_Component
+
+ -- Must have size clause and all scalar components
+
+ and then Has_Size_Clause (Rec)
+ and then All_Scalar_Components
+
+ -- Do not try implicit packing on records with discriminants, too
+ -- complicated, especially in the variant record case.
+
+ and then not Has_Discriminants (Rec)
+
+ -- We can implicitly pack if the specified size of the record is
+ -- less than the sum of the object sizes (no point in packing if
+ -- this is not the case).
+
+ and then Esize (Rec) < Scalar_Component_Total_Esize
+
+ -- And the total RM size cannot be greater than the specified size
+ -- since otherwise packing will not get us where we have to be!
+
+ and then Esize (Rec) >= Scalar_Component_Total_RM_Size
+
+ -- Never do implicit packing in CodePeer mode since we don't do
+ -- any packing ever in this mode (why not???)
+
+ and then not CodePeer_Mode
+ then
+ -- If implicit packing enabled, do it
+
+ if Implicit_Packing then
+ Set_Is_Packed (Rec);
+
+ -- Otherwise flag the size clause
+
+ else
+ declare
+ Sz : constant Node_Id := Size_Clause (Rec);
+ begin
+ Error_Msg_NE -- CODEFIX
+ ("size given for& too small", Sz, Rec);
+ Error_Msg_N -- CODEFIX
+ ("\use explicit pragma Pack "
+ & "or use pragma Implicit_Packing", Sz);
+ end;
+ end if;
+ end if;
end Freeze_Record_Type;
-- Start of processing for Freeze_Entity
Set_Encoded_Interface_Name
(E, Get_Default_External_Name (E));
- -- Special processing for atomic objects appearing in object decls
+ -- If entity is an atomic object appearing in a declaration and
+ -- the expression is an aggregate, assign it 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).
elsif Is_Atomic (E)
and then Nkind (Parent (E)) = N_Object_Declaration
and then Present (Expression (Parent (E)))
+ and then Nkind (Expression (Parent (E))) = N_Aggregate
+ and then
+ Is_Atomic_Aggregate (Expression (Parent (E)), Etype (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;
+ null;
end if;
-- For a subprogram, freeze all parameter types and also the return
-- 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.
+ -- created since we now know whether the subprogram will use a
+ -- foreign convention.
if Is_Subprogram (E) then
if not Is_Internal (E) then
-- If the type of a formal is incomplete, subprogram
-- is being frozen prematurely. Within an instance
-- (but not within a wrapper package) this is an
- -- an artifact of our need to regard the end of 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
Set_Is_Frozen (E, False);
return No_List;
and then Convention (E) = Convention_C
then
Error_Msg_N
- ("?& is a tagged type which does not "
+ ("?& involves a tagged type which does not "
& "correspond to any C type!", Formal);
-- Check wrong convention subprogram pointer
end if;
end if;
- if Is_Array_Type (R_Type)
+ -- Give warning for suspicous return of a result of an
+ -- unconstrained array type in a foreign convention
+ -- function.
+
+ if Has_Foreign_Convention (E)
+
+ -- We are looking for a return of unconstrained array
+
+ and then Is_Array_Type (R_Type)
and then not Is_Constrained (R_Type)
+
+ -- Exclude imported routines, the warning does not
+ -- belong on the import, but on the routine definition.
+
and then not Is_Imported (E)
- and then Has_Foreign_Convention (E)
+
+ -- Exclude VM case, since both .NET and JVM can handle
+ -- return of unconstrained arrays without a problem.
+
+ and then VM_Target = No_VM
+
+ -- Check that general warning is enabled, and that it
+ -- is not suppressed for this particular case.
+
and then Warn_On_Export_Import
and then not Has_Warnings_Off (E)
and then not Has_Warnings_Off (R_Type)
-- Here for other than a subprogram or type
else
- -- For a generic package, freeze types within, so that proper
- -- cross-reference information is generated for tagged types.
- -- This is the only freeze processing needed for generic packages.
-
- if Ekind (E) = E_Generic_Package then
- declare
- T : Entity_Id;
-
- begin
- T := First_Entity (E);
- while Present (T) loop
- if Is_Type (T) then
- Generate_Prim_Op_References (T);
- end if;
-
- Next_Entity (T);
- end loop;
- end;
-
-- If entity has a type, and it is not a generic unit, then
-- freeze it first (RM 13.14(10)).
- elsif Present (Etype (E))
+ if Present (Etype (E))
and then Ekind (E) /= E_Generic_Function
then
Freeze_And_Append (Etype (E), Loc, Result);
if Nkind (Declaration_Node (E)) = N_Object_Declaration then
+ -- Abstract type allowed only for C++ imported variables or
+ -- constants.
+
+ -- Note: we inhibit this check for objects that do not come
+ -- from source because there is at least one case (the
+ -- expansion of x'class'input where x is abstract) where we
+ -- legitimately generate an abstract object.
+
+ if Is_Abstract_Type (Etype (E))
+ and then Comes_From_Source (Parent (E))
+ and then not (Is_Imported (E)
+ and then Is_CPP_Class (Etype (E)))
+ then
+ Error_Msg_N ("type of object cannot be abstract",
+ Object_Definition (Parent (E)));
+
+ if Is_CPP_Class (Etype (E)) then
+ Error_Msg_NE ("\} may need a cpp_constructor",
+ Object_Definition (Parent (E)), Etype (E));
+ end if;
+ 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
and then not Is_Limited_Composite (E)
and then not Is_Packed (Root_Type (E))
and then not Has_Component_Size_Clause (Root_Type (E))
+ and then not CodePeer_Mode
then
Get_Index_Bounds (First_Index (E), Lo, Hi);
-- 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)
+ -- multiple of storage unit). If the component RM size
+ -- is an exact number of storage units that is a power
+ -- of two, the array is not packed and has a standard
+ -- representation.
begin
if RM_Size (E) = Len * Rsiz
and then Rsiz mod System_Storage_Unit /= 0
then
-- For implicit packing mode, just set the
- -- component size silently
+ -- component size silently.
if Implicit_Packing then
Set_Component_Size (Btyp, Rsiz);
("\use explicit pragma Pack "
& "or use pragma Implicit_Packing", SZ);
end if;
+
+ elsif RM_Size (E) = Len * Rsiz
+ and then Implicit_Packing
+ and then
+ (Rsiz / System_Storage_Unit = 1
+ or else Rsiz / System_Storage_Unit = 2
+ or else Rsiz / System_Storage_Unit = 4)
+ then
+
+ -- Not a packed array, but indicate the desired
+ -- component size, for the back-end.
+
+ Set_Component_Size (Btyp, Rsiz);
end if;
end;
end if;
-- later when the full type is frozen).
elsif Ekind (E) = E_Record_Type
- or else Ekind (E) = E_Record_Subtype
+ or else Ekind (E) = E_Record_Subtype
then
Freeze_Record_Type (E);
end if;
Comp := First_Entity (E);
-
while Present (Comp) loop
if Is_Type (Comp) then
Freeze_And_Append (Comp, Loc, Result);
elsif Is_Integer_Type (E) then
Adjust_Esize_For_Alignment (E);
+ if Is_Modular_Integer_Type (E)
+ and then Warn_On_Suspicious_Modulus_Value
+ then
+ Check_Suspicious_Modulus (E);
+ end if;
+
elsif Is_Access_Type (E) then
-- Check restriction for standard storage pool
end if;
end if;
- -- Generate references to primitive operations for a tagged type
-
- Generate_Prim_Op_References (E);
-
-- 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 alignment is required
-- designated type is a private type without full view, the expression
-- cannot contain an allocator, so the type is not frozen.
+ -- For a function, we freeze the entity when the subprogram declaration
+ -- is frozen, but a function call may appear in an initialization proc.
+ -- before the declaration is frozen. We need to generate the extra
+ -- formals, if any, to ensure that the expansion of the call includes
+ -- the proper actuals. This only applies to Ada subprograms, not to
+ -- imported ones.
+
Desig_Typ := Empty;
case Nkind (N) is
Desig_Typ := Designated_Type (Etype (Prefix (N)));
end if;
+ when N_Identifier =>
+ if Present (Nam)
+ and then Ekind (Nam) = E_Function
+ and then Nkind (Parent (N)) = N_Function_Call
+ and then Convention (Nam) = Convention_Ada
+ then
+ Create_Extra_Formals (Nam);
+ end if;
+
when others =>
null;
end case;
return;
end if;
- -- Loop for looking at the right place to insert the freeze nodes
+ -- Loop for looking at the right place to insert the freeze nodes,
-- exiting from the loop when it is appropriate to insert the freeze
-- node before the current node P.
- -- Also checks some special exceptions to the freezing rules. These
- -- cases result in a direct return, bypassing the freeze action.
+ -- Also checks som special exceptions to the freezing rules. These cases
+ -- result in a direct return, bypassing the freeze action.
P := N;
loop
exception
when Cannot_Be_Static =>
- -- If the object that cannot be static is imported or exported,
- -- then we give an error message saying that this object cannot
- -- be imported or exported.
+ -- If the object that cannot be static is imported or exported, then
+ -- issue an error message saying that this object cannot be imported
+ -- or exported. If it has an address clause it is an overlay in the
+ -- current partition and the static requirement is not relevant.
- if Is_Imported (E) then
+ if Is_Imported (E) and then No (Address_Clause (E)) then
Error_Msg_N
("& cannot be imported (local type is not constant)", E);
elsif Is_Generic_Type (Etype (E)) then
null;
+ -- Display warning if returning unconstrained array
+
elsif Is_Array_Type (Retype)
and then not Is_Constrained (Retype)
+
+ -- Exclude cases where descriptor mechanism is set, since the
+ -- VMS descriptor mechanisms allow such unconstrained returns.
+
and then Mechanism (E) not in Descriptor_Codes
+
+ -- Check appropriate warning is enabled (should we check for
+ -- Warnings (Off) on specific entities here, probably so???)
+
and then Warn_On_Export_Import
+
+ -- Exclude the VM case, since return of unconstrained arrays
+ -- is properly handled in both the JVM and .NET cases.
+
+ and then VM_Target = No_VM
then
Error_Msg_N
("?foreign convention function& should not return " &
end if;
end if;
- -- For VMS, descriptor mechanisms for parameters are allowed only
- -- for imported/exported subprograms. Moreover, the NCA descriptor
- -- is not allowed for parameters of exported subprograms.
+ -- For VMS, descriptor mechanisms for parameters are allowed only for
+ -- imported/exported subprograms. Moreover, the NCA descriptor is not
+ -- allowed for parameters of exported subprograms.
if OpenVMS_On_Target then
if Is_Exported (E) then
end Is_Fully_Defined;
---------------------------------
- -- Generate_Prim_Op_References --
- ---------------------------------
-
- procedure Generate_Prim_Op_References (Typ : Entity_Id) is
- Base_T : Entity_Id;
- Prim : Elmt_Id;
- Prim_List : Elist_Id;
- Ent : Entity_Id;
-
- begin
- -- Handle subtypes of synchronized types
-
- if Ekind (Typ) = E_Protected_Subtype
- or else Ekind (Typ) = E_Task_Subtype
- then
- Base_T := Etype (Typ);
- else
- Base_T := Typ;
- end if;
-
- -- References to primitive operations are only relevant for tagged types
-
- if not Is_Tagged_Type (Base_T)
- or else Is_Class_Wide_Type (Base_T)
- then
- return;
- end if;
-
- -- Ada 2005 (AI-345): For synchronized types generate reference
- -- to the wrapper that allow us to dispatch calls through their
- -- implemented abstract interface types.
-
- -- The check for Present here is to protect against previously
- -- reported critical errors.
-
- if Is_Concurrent_Type (Base_T)
- and then Present (Corresponding_Record_Type (Base_T))
- then
- Prim_List := Primitive_Operations
- (Corresponding_Record_Type (Base_T));
- else
- Prim_List := Primitive_Operations (Base_T);
- end if;
-
- if No (Prim_List) then
- return;
- end if;
-
- Prim := First_Elmt (Prim_List);
- while Present (Prim) loop
-
- -- If the operation is derived, get the original for cross-reference
- -- reference purposes (it is the original for which we want the xref
- -- and for which the comes_from_source test must be performed).
-
- Ent := Node (Prim);
- while Present (Alias (Ent)) loop
- Ent := Alias (Ent);
- end loop;
-
- Generate_Reference (Typ, Ent, 'p', Set_Ref => False);
- Next_Elmt (Prim);
- end loop;
- end Generate_Prim_Op_References;
-
- ---------------------------------
-- Process_Default_Expressions --
---------------------------------
OSDN Git Service
