Set_Error_Posted (N);
- -- If it is a subexpression, then set Error_Posted on parents
- -- up to and including the first non-subexpression construct. This
- -- helps avoid cascaded error messages within a single expression.
+ -- If it is a subexpression, then set Error_Posted on parents up to
+ -- and including the first non-subexpression construct. This helps
+ -- avoid cascaded error messages within a single expression.
P := N;
loop
-- Special_Msg_Delete --
------------------------
+ -- Is it really right to have all this specialized knowledge in errout?
+
function Special_Msg_Delete
(Msg : String;
N : Node_Or_Entity_Id;
if Debug_Flag_OO then
return False;
- -- When an atomic object refers to a non-atomic type in the same
- -- scope, we implicitly make the type atomic. In the non-error
- -- case this is surely safe (and in fact prevents an error from
- -- occurring if the type is not atomic by default). But if the
- -- object cannot be made atomic, then we introduce an extra junk
- -- message by this manipulation, which we get rid of here.
+ -- Processing for "atomic access cannot be guaranteed"
- -- We identify this case by the fact that it references a type for
- -- which Is_Atomic is set, but there is no Atomic pragma setting it.
+ elsif Msg = "atomic access to & cannot be guaranteed" then
- elsif Msg = "atomic access to & cannot be guaranteed"
- and then Is_Type (E)
- and then Is_Atomic (E)
- and then No (Get_Rep_Pragma (E, Name_Atomic))
- then
- return True;
+ -- When an atomic object refers to a non-atomic type in the same
+ -- scope, we implicitly make the type atomic. In the non-error case
+ -- this is surely safe (and in fact prevents an error from occurring
+ -- if the type is not atomic by default). But if the object cannot be
+ -- made atomic, then we introduce an extra junk message by this
+ -- manipulation, which we get rid of here.
- -- When a size is wrong for a frozen type there is no explicit
- -- size clause, and other errors have occurred, suppress the
- -- message, since it is likely that this size error is a cascaded
- -- result of other errors. The reason we eliminate unfrozen types
- -- is that messages issued before the freeze type are for sure OK.
- -- Also suppress "size too small" errors in CodePeer mode, since pragma
- -- Pack is also ignored in this configuration.
-
- elsif Msg = "size for& too small, minimum allowed is ^"
- and then (CodePeer_Mode
- or else (Is_Frozen (E)
- and then Serious_Errors_Detected > 0
- and then Nkind (N) /= N_Component_Clause
- and then Nkind (Parent (N)) /= N_Component_Clause
- and then
- No (Get_Attribute_Definition_Clause (E, Attribute_Size))
- and then
- No (Get_Attribute_Definition_Clause (E, Attribute_Object_Size))
- and then
- No (Get_Attribute_Definition_Clause (E, Attribute_Value_Size))))
- then
- return True;
+ -- We identify this case by the fact that it references a type for
+ -- which Is_Atomic is set, but there is no Atomic pragma setting it.
- -- All special tests complete, so go ahead with message
+ if Is_Type (E)
+ and then Is_Atomic (E)
+ and then No (Get_Rep_Pragma (E, Name_Atomic))
+ then
+ return True;
+ end if;
- else
- return False;
+ -- Processing for "Size too small" messages
+
+ elsif Msg = "size for& too small, minimum allowed is ^" then
+
+ -- Suppress "size too small" errors in CodePeer mode, since pragma
+ -- Pack is also ignored in this configuration.
+
+ if CodePeer_Mode then
+ return True;
+
+ -- When a size is wrong for a frozen type there is no explicit size
+ -- clause, and other errors have occurred, suppress the message,
+ -- since it is likely that this size error is a cascaded result of
+ -- other errors. The reason we eliminate unfrozen types is that
+ -- messages issued before the freeze type are for sure OK.
+
+ elsif Is_Frozen (E)
+ and then Serious_Errors_Detected > 0
+ and then Nkind (N) /= N_Component_Clause
+ and then Nkind (Parent (N)) /= N_Component_Clause
+ and then
+ No (Get_Attribute_Definition_Clause (E, Attribute_Size))
+ and then
+ No (Get_Attribute_Definition_Clause (E, Attribute_Object_Size))
+ and then
+ No (Get_Attribute_Definition_Clause (E, Attribute_Value_Size))
+ then
+ return True;
+ end if;
end if;
+
+ -- All special tests complete, so go ahead with message
+
+ return False;
end Special_Msg_Delete;
--------------------------
Msglen := Msglen - 1;
end if;
- -- The loop here deals with recursive types, we are trying to
- -- find a related entity that is not an implicit type. Note
- -- that the check with Old_Ent stops us from getting "stuck".
- -- Also, we don't output the "type derived from" message more
- -- than once in the case where we climb up multiple levels.
+ -- The loop here deals with recursive types, we are trying to find a
+ -- related entity that is not an implicit type. Note that the check with
+ -- Old_Ent stops us from getting "stuck". Also, we don't output the
+ -- "type derived from" message more than once in the case where we climb
+ -- up multiple levels.
loop
Old_Ent := Ent;
- -- Implicit access type, use directly designated type
- -- In Ada 2005, the designated type may be an anonymous access to
- -- subprogram, in which case we can only point to its definition.
+ -- Implicit access type, use directly designated type In Ada 2005,
+ -- the designated type may be an anonymous access to subprogram, in
+ -- which case we can only point to its definition.
if Is_Access_Type (Ent) then
if Ekind (Ent) = E_Access_Subprogram_Type
Ent := Base_Type (Ent);
- -- If this is a base type with a first named subtype, use the
- -- first named subtype instead. This is not quite accurate in
- -- all cases, but it makes too much noise to be accurate and
- -- add 'Base in all cases. Note that we only do this is the
- -- first named subtype is not itself an internal name. This
- -- avoids the obvious loop (subtype->basetype->subtype) which
- -- would otherwise occur!)
+ -- If this is a base type with a first named subtype, use the first
+ -- named subtype instead. This is not quite accurate in all cases,
+ -- but it makes too much noise to be accurate and add 'Base in all
+ -- cases. Note that we only do this is the first named subtype is not
+ -- itself an internal name. This avoids the obvious loop (subtype ->
+ -- basetype -> subtype) which would otherwise occur!)
elsif Present (Freeze_Node (Ent))
and then Present (First_Subtype_Link (Freeze_Node (Ent)))
end;
end if;
- -- See if Implicit_Packing would work
+ -- 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
else
if not Rep_Item_Too_Late (Typ, N) then
+
+ -- In the context of static code analysis, we do not need
+ -- complex front-end expansions related to pragma Pack,
+ -- so disable handling of pragma Pack in this case.
+
if CodePeer_Mode then
- -- Ignore pragma Pack and disable corresponding
- -- complex expansions in CodePeer mode
null;
+ -- For normal non-VM target, do the packing
+
elsif VM_Target = No_VM then
Set_Is_Packed (Base_Type (Typ));
Set_Has_Pragma_Pack (Base_Type (Typ));
- Set_Has_Non_Standard_Rep (Base_Type (Typ));
+ Set_Has_Non_Standard_Rep (Base_Type (Typ));
+
+ -- If we ignore the pack, then warn about this, except
+ -- that we suppress the warning in GNAT mode.
elsif not GNAT_Mode then
Error_Pragma
else pragma Assert (Is_Record_Type (Typ));
if not Rep_Item_Too_Late (Typ, N) then
- if CodePeer_Mode then
- -- Ignore pragma Pack and disable corresponding
- -- complex expansions in CodePeer mode
- null;
-
- elsif VM_Target = No_VM then
+ if VM_Target = No_VM then
Set_Is_Packed (Base_Type (Typ));
Set_Has_Pragma_Pack (Base_Type (Typ));
Set_Has_Non_Standard_Rep (Base_Type (Typ));
projects / platform / upstream / gcc.git / commitdiff