Skip to content

R
riscv-gcc-1
Commit 63bb4268 by Arnaud Charlet
Options

[multiple changes] 

2013-10-14  Arnaud Charlet  <charlet@adacore.com>

	* exp_ch11.adb: Fix typo.

2013-10-14  Thomas Quinot  <quinot@adacore.com>

	* exp_util.ads: Minor reformatting.

2013-10-14  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Build_Derived_Record_Type): Reject full views
	with no explicit discriminant constraints, when the parents of
	the partial view and the full view are constrained subtypes with
	different constraints.

2013-10-14  Robert Dewar  <dewar@adacore.com>

	* freeze.adb (Freeze_Array_Type): New procedure, abstracts out
	this code from Freeze.
	(Freeze_Array_Type): Detect pragma Pack overriding foreign convention
	(Freeze_Record_Type): Ditto.

From-SVN: r203553
parent e74d643a
Showing with 632 additions and 532 deletions
gcc/ada/ChangeLog
2013-10-14 Arnaud Charlet <charlet@adacore.com>
* exp_ch11.adb: Fix typo.
2013-10-14 Thomas Quinot <quinot@adacore.com>
* exp_util.ads: Minor reformatting.
2013-10-14 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb (Build_Derived_Record_Type): Reject full views
with no explicit discriminant constraints, when the parents of
the partial view and the full view are constrained subtypes with
different constraints.
2013-10-14 Robert Dewar <dewar@adacore.com>
* freeze.adb (Freeze_Array_Type): New procedure, abstracts out
this code from Freeze.
(Freeze_Array_Type): Detect pragma Pack overriding foreign convention
(Freeze_Record_Type): Ditto.
2013-10-14 Hristian Kirtchev <kirtchev@adacore.com> 2013-10-14 Hristian Kirtchev <kirtchev@adacore.com>
* sem_prag.adb (Analyze_Dependency_Clause): Add new local variable * sem_prag.adb (Analyze_Dependency_Clause): Add new local variable
......
gcc/ada/exp_ch11.adb
...@@ -1026,7 +1026,7 @@ package body Exp_Ch11 is ...@@ -1026,7 +1026,7 @@ package body Exp_Ch11 is
-- end; -- end;
-- This expansion is not performed when using GCC ZCX. Gigi -- This expansion is not performed when using GCC ZCX. Gigi
-- will insert a call to intialize the choice parameter. -- will insert a call to initialize the choice parameter.
if Present (Choice_Parameter (Handler)) if Present (Choice_Parameter (Handler))
and then Exception_Mechanism /= Back_End_Exceptions and then Exception_Mechanism /= Back_End_Exceptions
......
gcc/ada/exp_util.ads
...@@ -359,9 +359,9 @@ package Exp_Util is ...@@ -359,9 +359,9 @@ package Exp_Util is
-- by the compiler and used by GDB. -- by the compiler and used by GDB.
procedure Evaluate_Name (Nam : Node_Id); procedure Evaluate_Name (Nam : Node_Id);
-- Remove the all side effects from a name which appears as part of an -- Remove all side effects from a name which appears as part of an object
-- object renaming declaration. More comments are needed here that explain -- renaming declaration. More comments are needed here that explain how
-- how this differs from Force_Evaluation and Remove_Side_Effects ??? -- this differs from Force_Evaluation and Remove_Side_Effects ???
procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id); procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id);
-- Rewrites Cond with the expression: Cond and then Cond1. If Cond is -- Rewrites Cond with the expression: Cond and then Cond1. If Cond is
......
gcc/ada/freeze.adb
...@@ -1698,12 +1698,15 @@ package body Freeze is ...@@ -1698,12 +1698,15 @@ package body Freeze is
-- integer literal without an explicit corresponding size clause. The -- integer literal without an explicit corresponding size clause. The
-- caller has checked that Utype is a modular integer type. -- caller has checked that Utype is a modular integer type.
procedure Freeze_Array_Type (Arr : Entity_Id);
-- Freeze array type, including freezing index and component types
function Freeze_Generic_Entities (Pack : Entity_Id) return List_Id; function Freeze_Generic_Entities (Pack : Entity_Id) return List_Id;
-- Create Freeze_Generic_Entity nodes for types declared in a generic -- Create Freeze_Generic_Entity nodes for types declared in a generic
-- package. Recurse on inner generic packages. -- package. Recurse on inner generic packages.
procedure Freeze_Record_Type (Rec : Entity_Id); procedure Freeze_Record_Type (Rec : Entity_Id);
-- Freeze each component, handle some representation clauses, and freeze -- Freeze record type, including freezing component types, and freezing
-- primitive operations if this is a tagged type. -- primitive operations if this is a tagged type.
------------------- -------------------
...@@ -1948,6 +1951,529 @@ package body Freeze is ...@@ -1948,6 +1951,529 @@ package body Freeze is
end if; end if;
end Check_Suspicious_Modulus; end Check_Suspicious_Modulus;
-----------------------
-- Freeze_Array_Type --
-----------------------
procedure Freeze_Array_Type (Arr : Entity_Id) is
FS : constant Entity_Id := First_Subtype (Arr);
Ctyp : constant Entity_Id := Component_Type (Arr);
Clause : Entity_Id;
Non_Standard_Enum : Boolean := False;
-- Set true if any of the index types is an enumeration type with a
-- non-standard representation.
begin
Freeze_And_Append (Ctyp, N, Result);
Indx := First_Index (Arr);
while Present (Indx) loop
Freeze_And_Append (Etype (Indx), N, Result);
if Is_Enumeration_Type (Etype (Indx))
and then Has_Non_Standard_Rep (Etype (Indx))
then
Non_Standard_Enum := True;
end if;
Next_Index (Indx);
end loop;
-- Processing that is done only for base types
if Ekind (Arr) = E_Array_Type then
-- Propagate flags for component type
if Is_Controlled (Component_Type (Arr))
or else Has_Controlled_Component (Ctyp)
then
Set_Has_Controlled_Component (Arr);
end if;
if Has_Unchecked_Union (Component_Type (Arr)) then
Set_Has_Unchecked_Union (Arr);
end if;
-- Warn for pragma Pack overriding foreign convention
if Has_Foreign_Convention (Ctyp)
and then Has_Pragma_Pack (Arr)
then
declare
CN : constant Name_Id :=
Get_Convention_Name (Convention (Ctyp));
PP : constant Node_Id :=
Get_Pragma (First_Subtype (Arr), Pragma_Pack);
begin
if Present (PP) then
Error_Msg_Name_1 := CN;
Error_Msg_Sloc := Sloc (Arr);
Error_Msg_N
("pragma Pack affects convention % components #??",
PP);
Error_Msg_Name_1 := CN;
Error_Msg_N
("\array components may not have % compatible "
& "representation??", PP);
end if;
end;
end if;
-- If packing was requested or if the component size was
-- set explicitly, then see if bit packing is required. This
-- processing is only done for base types, since all of the
-- representation aspects involved are type-related. This is not
-- just an optimization, if we start processing the subtypes, they
-- interfere with the settings on the base type (this is because
-- Is_Packed has a slightly different meaning before and after
-- freezing).
declare
Csiz : Uint;
Esiz : Uint;
begin
if (Is_Packed (Arr) or else Has_Pragma_Pack (Arr))
and then Known_Static_RM_Size (Ctyp)
and then not Has_Component_Size_Clause (Arr)
then
Csiz := UI_Max (RM_Size (Ctyp), 1);
elsif Known_Component_Size (Arr) then
Csiz := Component_Size (Arr);
elsif not Known_Static_Esize (Ctyp) then
Csiz := Uint_0;
else
Esiz := Esize (Ctyp);
-- We can set the component size if it is less than 16,
-- rounding it up to the next storage unit size.
if Esiz <= 8 then
Csiz := Uint_8;
elsif Esiz <= 16 then
Csiz := Uint_16;
else
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 size (the
-- padded type cases).
if Csiz /= 0 then
declare
A : constant Uint := Alignment_In_Bits (Ctyp);
begin
if Csiz < A then
Csiz := A;
end if;
end;
end if;
end if;
-- Case of component size that may result in packing
if 1 <= Csiz and then Csiz <= 64 then
declare
Ent : constant Entity_Id :=
First_Subtype (Arr);
Pack_Pragma : constant Node_Id :=
Get_Rep_Pragma (Ent, Name_Pack);
Comp_Size_C : constant Node_Id :=
Get_Attribute_Definition_Clause
(Ent, Attribute_Component_Size);
begin
-- Warn if we have pack and component size so that the
-- pack is ignored.
-- Note: here we must check for the presence of a
-- component size before checking for a Pack pragma to
-- deal with the case where the array type is a derived
-- type whose parent is currently private.
if Present (Comp_Size_C)
and then Has_Pragma_Pack (Ent)
and then Warn_On_Redundant_Constructs
then
Error_Msg_Sloc := Sloc (Comp_Size_C);
Error_Msg_NE
("?r?pragma Pack for& ignored!",
Pack_Pragma, Ent);
Error_Msg_N
("\?r?explicit component size given#!",
Pack_Pragma);
Set_Is_Packed (Base_Type (Ent), False);
Set_Is_Bit_Packed_Array (Base_Type (Ent), False);
end if;
-- Set component size if not already set by a component
-- size clause.
if not Present (Comp_Size_C) then
Set_Component_Size (Arr, Csiz);
end if;
-- Check for base type of 8, 16, 32 bits, where an
-- unsigned subtype has a length one less than the
-- base type (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 (Arr)
and then not Present (Comp_Size_C)
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;
if Present (Pack_Pragma) then
Error_Msg_N
("??pragma Pack causes component size "
& "to be ^!", Pack_Pragma);
Error_Msg_N
("\??use Component_Size to set "
& "desired value!", Pack_Pragma);
end if;
end if;
-- 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
or else Csiz = 32
or else Csiz = 64
or else (Csiz = 24 and then Alignment (Ctyp) = 1)
then
-- Here the array was requested to be packed, but
-- 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 pragma
-- Pack that was non- effective, but that seems fine.
-- We regard a Pack pragma as a request to set a
-- representation characteristic, and this request
-- may be ignored.
Set_Is_Packed (Base_Type (Arr), False);
Set_Is_Bit_Packed_Array (Base_Type (Arr), False);
if Known_Static_Esize (Component_Type (Arr))
and then Esize (Component_Type (Arr)) = Csiz
then
Set_Has_Non_Standard_Rep
(Base_Type (Arr), False);
end if;
-- In all other cases, packing is indeed needed
else
Set_Has_Non_Standard_Rep (Base_Type (Arr), True);
Set_Is_Bit_Packed_Array (Base_Type (Arr), True);
Set_Is_Packed (Base_Type (Arr), True);
end if;
end;
end if;
end;
-- Check for Atomic_Components or Aliased with unsuitable packing
-- or explicit component size clause given.
if (Has_Atomic_Components (Arr)
or else Has_Aliased_Components (Arr))
and then (Has_Component_Size_Clause (Arr)
or else Is_Packed (Arr))
then
Alias_Atomic_Check : declare
procedure Complain_CS (T : String);
-- Outputs error messages for incorrect CS clause or pragma
-- Pack for aliased or atomic components (T is "aliased" or
-- "atomic");
-----------------
-- Complain_CS --
-----------------
procedure Complain_CS (T : String) is
begin
if Has_Component_Size_Clause (Arr) then
Clause :=
Get_Attribute_Definition_Clause
(FS, Attribute_Component_Size);
if Known_Static_Esize (Ctyp) then
Error_Msg_N
("incorrect component size for "
& T & " components", Clause);
Error_Msg_Uint_1 := Esize (Ctyp);
Error_Msg_N
("\only allowed value is^", Clause);
else
Error_Msg_N
("component size cannot be given for "
& T & " components", Clause);
end if;
else
Error_Msg_N
("cannot pack " & T & " components",
Get_Rep_Pragma (FS, Name_Pack));
end if;
return;
end Complain_CS;
-- Start of processing for Alias_Atomic_Check
begin
-- If object size of component type isn't known, we cannot
-- be sure so we defer to the back end.
if not Known_Static_Esize (Ctyp) then
null;
-- Case where component size has no effect. First check for
-- object size of component type multiple of the storage
-- unit size.
elsif Esize (Ctyp) mod System_Storage_Unit = 0
-- OK in both packing case and component size case if RM
-- size is known and static and same as the object size.
and then
((Known_Static_RM_Size (Ctyp)
and then Esize (Ctyp) = RM_Size (Ctyp))
-- Or if we have an explicit component size clause and
-- the component size and object size are equal.
or else
(Has_Component_Size_Clause (Arr)
and then Component_Size (Arr) = Esize (Ctyp)))
then
null;
elsif Has_Aliased_Components (Arr)
or else Is_Aliased (Ctyp)
then
Complain_CS ("aliased");
elsif Has_Atomic_Components (Arr)
or else Is_Atomic (Ctyp)
then
Complain_CS ("atomic");
end if;
end Alias_Atomic_Check;
end if;
-- Warn for case of atomic type
Clause := Get_Rep_Pragma (FS, Name_Atomic);
if Present (Clause)
and then not Addressable (Component_Size (FS))
then
Error_Msg_NE
("non-atomic components of type& may not be "
& "accessible by separate tasks??", Clause, Arr);
if Has_Component_Size_Clause (Arr) then
Error_Msg_Sloc :=
Sloc
(Get_Attribute_Definition_Clause
(FS, Attribute_Component_Size));
Error_Msg_N
("\because of component size clause#??",
Clause);
elsif Has_Pragma_Pack (Arr) then
Error_Msg_Sloc :=
Sloc (Get_Rep_Pragma (FS, Name_Pack));
Error_Msg_N
("\because of pragma Pack#??", Clause);
end if;
end if;
-- Check for scalar storage order
if Present (Get_Attribute_Definition_Clause
(Arr, Attribute_Scalar_Storage_Order))
then
Check_Component_Storage_Order (Arr, Empty);
end if;
-- Processing that is done only for subtypes
else
-- Acquire alignment from base type
if Unknown_Alignment (Arr) then
Set_Alignment (Arr, Alignment (Base_Type (Arr)));
Adjust_Esize_Alignment (Arr);
end if;
end if;
-- Specific checks for bit-packed arrays
if Is_Bit_Packed_Array (Arr) then
-- Check number of elements for bit packed arrays that come from
-- source and have compile time known ranges. The bit-packed
-- arrays circuitry does not support arrays with more than
-- Integer'Last + 1 elements, and when this restriction is
-- violated, causes incorrect data access.
-- For the case where this is not compile time known, a run-time
-- check should be generated???
if Comes_From_Source (Arr) and then Is_Constrained (Arr) then
declare
Elmts : Uint;
Index : Node_Id;
Ilen : Node_Id;
Ityp : Entity_Id;
begin
Elmts := Uint_1;
Index := First_Index (Arr);
while Present (Index) loop
Ityp := Etype (Index);
-- Never generate an error if any index is of a generic
-- type. We will check this in instances.
if Is_Generic_Type (Ityp) then
Elmts := Uint_0;
exit;
end if;
Ilen :=
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Ityp, Loc),
Attribute_Name => Name_Range_Length);
Analyze_And_Resolve (Ilen);
-- No attempt is made to check number of elements
-- if not compile time known.
if Nkind (Ilen) /= N_Integer_Literal then
Elmts := Uint_0;
exit;
end if;
Elmts := Elmts * Intval (Ilen);
Next_Index (Index);
end loop;
if Elmts > Intval (High_Bound
(Scalar_Range
(Standard_Integer))) + 1
then
Error_Msg_N
("bit packed array type may not have "
& "more than Integer''Last+1 elements", Arr);
end if;
end;
end if;
-- Check size
if Known_RM_Size (Arr) then
declare
SizC : constant Node_Id := Size_Clause (Arr);
Discard : Boolean;
pragma Warnings (Off, Discard);
begin
-- It is not clear if it is possible to have no 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), Arr, RM_Size (Arr), Discard);
else
Check_Size (Arr, Arr, RM_Size (Arr), Discard);
end if;
end;
end if;
end if;
-- If any of the index types was an enumeration type with a
-- non-standard rep clause, then we indicate that the array type
-- is always packed (even if it is not bit packed).
if Non_Standard_Enum then
Set_Has_Non_Standard_Rep (Base_Type (Arr));
Set_Is_Packed (Base_Type (Arr));
end if;
Set_Component_Alignment_If_Not_Set (Arr);
-- 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 (Arr)
and then Ekind (Arr) /= E_String_Literal_Subtype
then
Create_Packed_Array_Type (Arr);
Freeze_And_Append (Packed_Array_Type (Arr), N, Result);
-- Size information of packed array type is copied to the array
-- type, since this is really the representation. But do not
-- override explicit existing size values. If the ancestor subtype
-- is constrained the packed_array_type will be inherited from it,
-- but the size may have been provided already, and must not be
-- overridden either.
if not Has_Size_Clause (Arr)
and then
(No (Ancestor_Subtype (Arr))
or else not Has_Size_Clause (Ancestor_Subtype (Arr)))
then
Set_Esize (Arr, Esize (Packed_Array_Type (Arr)));
Set_RM_Size (Arr, RM_Size (Packed_Array_Type (Arr)));
end if;
if not Has_Alignment_Clause (Arr) then
Set_Alignment (Arr, Alignment (Packed_Array_Type (Arr)));
end if;
end if;
-- For non-packed arrays set the alignment of the array to the
-- alignment of the component type if it is unknown. Skip this
-- in atomic case (atomic arrays may need larger alignments).
if not Is_Packed (Arr)
and then Unknown_Alignment (Arr)
and then Known_Alignment (Ctyp)
and then Known_Static_Component_Size (Arr)
and then Known_Static_Esize (Ctyp)
and then Esize (Ctyp) = Component_Size (Arr)
and then not Is_Atomic (Arr)
then
Set_Alignment (Arr, Alignment (Component_Type (Arr)));
end if;
end Freeze_Array_Type;
----------------------------- -----------------------------
-- Freeze_Generic_Entities -- -- Freeze_Generic_Entities --
----------------------------- -----------------------------
...@@ -2201,6 +2727,31 @@ package body Freeze is ...@@ -2201,6 +2727,31 @@ package body Freeze is
Freeze_And_Append (Etype (Comp), N, Result); Freeze_And_Append (Etype (Comp), N, Result);
-- Warn for pragma Pack overriding foreign convention
if Has_Foreign_Convention (Etype (Comp))
and then Has_Pragma_Pack (Rec)
then
declare
CN : constant Name_Id :=
Get_Convention_Name (Convention (Etype (Comp)));
PP : constant Node_Id :=
Get_Pragma (Rec, Pragma_Pack);
begin
if Present (PP) then
Error_Msg_Name_1 := CN;
Error_Msg_Sloc := Sloc (Comp);
Error_Msg_N
("pragma Pack affects convention % component#??",
PP);
Error_Msg_Name_1 := CN;
Error_Msg_NE
("\component & may not have % compatible "
& "representation??", PP, Comp);
end if;
end;
end if;
-- Check for error of component clause given for variable -- Check for error of component clause given for variable
-- sized type. We have to delay this test till this point, -- sized type. We have to delay this test till this point,
-- since the component type has to be frozen for us to know -- since the component type has to be frozen for us to know
...@@ -3749,506 +4300,10 @@ package body Freeze is ...@@ -3749,506 +4300,10 @@ package body Freeze is
Inherit_Aspects_At_Freeze_Point (E); Inherit_Aspects_At_Freeze_Point (E);
end if; end if;
-- For array type, freeze index types and component type first -- Array type
-- before freezing the array (RM 13.14(15)).
if Is_Array_Type (E) then if Is_Array_Type (E) then
declare Freeze_Array_Type (E);
FS : constant Entity_Id := First_Subtype (E);
Ctyp : constant Entity_Id := Component_Type (E);
Clause : Entity_Id;
Non_Standard_Enum : Boolean := False;
-- Set true if any of the index types is an enumeration type
-- with a non-standard representation.
begin
Freeze_And_Append (Ctyp, N, Result);
Indx := First_Index (E);
while Present (Indx) loop
Freeze_And_Append (Etype (Indx), N, Result);
if Is_Enumeration_Type (Etype (Indx))
and then Has_Non_Standard_Rep (Etype (Indx))
then
Non_Standard_Enum := True;
end if;
Next_Index (Indx);
end loop;
-- Processing that is done only for base types
if Ekind (E) = E_Array_Type then
-- Propagate flags for component type
if Is_Controlled (Component_Type (E))
or else Has_Controlled_Component (Ctyp)
then
Set_Has_Controlled_Component (E);
end if;
if Has_Unchecked_Union (Component_Type (E)) then
Set_Has_Unchecked_Union (E);
end if;
-- If packing was requested or if the component size was set
-- explicitly, then see if bit packing is required. This
-- processing is only done for base types, since all the
-- representation aspects involved are type-related. This
-- is not just an optimization, if we start processing the
-- subtypes, they interfere with the settings on the base
-- type (this is because Is_Packed has a slightly different
-- meaning before and after freezing).
declare
Csiz : Uint;
Esiz : Uint;
begin
if (Is_Packed (E) or else Has_Pragma_Pack (E))
and then Known_Static_RM_Size (Ctyp)
and then not Has_Component_Size_Clause (E)
then
Csiz := UI_Max (RM_Size (Ctyp), 1);
elsif Known_Component_Size (E) then
Csiz := Component_Size (E);
elsif not Known_Static_Esize (Ctyp) then
Csiz := Uint_0;
else
Esiz := Esize (Ctyp);
-- We can set the component size if it is less than
-- 16, rounding it up to the next storage unit size.
if Esiz <= 8 then
Csiz := Uint_8;
elsif Esiz <= 16 then
Csiz := Uint_16;
else
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 size (padded types).
if Csiz /= 0 then
declare
A : constant Uint := Alignment_In_Bits (Ctyp);
begin
if Csiz < A then
Csiz := A;
end if;
end;
end if;
end if;
-- Case of component size that may result in packing
if 1 <= Csiz and then Csiz <= 64 then
declare
Ent : constant Entity_Id :=
First_Subtype (E);
Pack_Pragma : constant Node_Id :=
Get_Rep_Pragma (Ent, Name_Pack);
Comp_Size_C : constant Node_Id :=
Get_Attribute_Definition_Clause
(Ent, Attribute_Component_Size);
begin
-- Warn if we have pack and component size so that
-- the pack is ignored.
-- Note: here we must check for the presence of a
-- component size before checking for a Pack pragma
-- to deal with the case where the array type is a
-- derived type whose parent is currently private.
if Present (Comp_Size_C)
and then Has_Pragma_Pack (Ent)
and then Warn_On_Redundant_Constructs
then
Error_Msg_Sloc := Sloc (Comp_Size_C);
Error_Msg_NE
("?r?pragma Pack for& ignored!",
Pack_Pragma, Ent);
Error_Msg_N
("\?r?explicit component size given#!",
Pack_Pragma);
Set_Is_Packed (Base_Type (Ent), False);
Set_Is_Bit_Packed_Array (Base_Type (Ent), False);
end if;
-- Set component size if not already set by a
-- component size clause.
if not Present (Comp_Size_C) then
Set_Component_Size (E, Csiz);
end if;
-- Check for base type of 8, 16, 32 bits, where an
-- unsigned subtype has a length one less than the
-- base type (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 Present (Comp_Size_C)
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;
if Present (Pack_Pragma) then
Error_Msg_N
("??pragma Pack causes component size "
& "to be ^!", Pack_Pragma);
Error_Msg_N
("\??use Component_Size to set "
& "desired value!", Pack_Pragma);
end if;
end if;
-- 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
or else Csiz = 32
or else Csiz = 64
or else (Csiz = 24 and then Alignment (Ctyp) = 1)
then
-- Here the array was requested to be packed,
-- but 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 pragma Pack that was non-
-- effective, but that seems fine.
-- We regard a Pack pragma as a request to set
-- a representation characteristic, and this
-- request may be ignored.
Set_Is_Packed (Base_Type (E), False);
Set_Is_Bit_Packed_Array (Base_Type (E), False);
if Known_Static_Esize (Component_Type (E))
and then Esize (Component_Type (E)) = Csiz
then
Set_Has_Non_Standard_Rep
(Base_Type (E), False);
end if;
-- In all other cases, packing is indeed needed
else
Set_Has_Non_Standard_Rep (Base_Type (E), True);
Set_Is_Bit_Packed_Array (Base_Type (E), True);
Set_Is_Packed (Base_Type (E), True);
end if;
end;
end if;
end;
-- Check for Atomic_Components or Aliased with unsuitable
-- packing or explicit component size clause given.
if (Has_Atomic_Components (E)
or else Has_Aliased_Components (E))
and then (Has_Component_Size_Clause (E)
or else Is_Packed (E))
then
Alias_Atomic_Check : declare
procedure Complain_CS (T : String);
-- Outputs error messages for incorrect CS clause or
-- pragma Pack for aliased or atomic components (T is
-- "aliased" or "atomic");
-----------------
-- Complain_CS --
-----------------
procedure Complain_CS (T : String) is
begin
if Has_Component_Size_Clause (E) then
Clause :=
Get_Attribute_Definition_Clause
(FS, Attribute_Component_Size);
if Known_Static_Esize (Ctyp) then
Error_Msg_N
("incorrect component size for "
& T & " components", Clause);
Error_Msg_Uint_1 := Esize (Ctyp);
Error_Msg_N
("\only allowed value is^", Clause);
else
Error_Msg_N
("component size cannot be given for "
& T & " components", Clause);
end if;
else
Error_Msg_N
("cannot pack " & T & " components",
Get_Rep_Pragma (FS, Name_Pack));
end if;
return;
end Complain_CS;
-- Start of processing for Alias_Atomic_Check
begin
-- If object size of component type isn't known, we
-- cannot be sure so we defer to the back end.
if not Known_Static_Esize (Ctyp) then
null;
-- Case where component size has no effect. First
-- check for object size of component type multiple
-- of the storage unit size.
elsif Esize (Ctyp) mod System_Storage_Unit = 0
-- OK in both packing case and component size case
-- if RM size is known and static and the same as
-- the object size.
and then
((Known_Static_RM_Size (Ctyp)
and then Esize (Ctyp) = RM_Size (Ctyp))
-- Or if we have an explicit component size
-- clause and the component size and object size
-- are equal.
or else
(Has_Component_Size_Clause (E)
and then Component_Size (E) = Esize (Ctyp)))
then
null;
elsif Has_Aliased_Components (E)
or else Is_Aliased (Ctyp)
then
Complain_CS ("aliased");
elsif Has_Atomic_Components (E)
or else Is_Atomic (Ctyp)
then
Complain_CS ("atomic");
end if;
end Alias_Atomic_Check;
end if;
-- Warn for case of atomic type
Clause := Get_Rep_Pragma (FS, Name_Atomic);
if Present (Clause)
and then not Addressable (Component_Size (FS))
then
Error_Msg_NE
("non-atomic components of type& may not be "
& "accessible by separate tasks??", Clause, E);
if Has_Component_Size_Clause (E) then
Error_Msg_Sloc :=
Sloc
(Get_Attribute_Definition_Clause
(FS, Attribute_Component_Size));
Error_Msg_N
("\because of component size clause#??",
Clause);
elsif Has_Pragma_Pack (E) then
Error_Msg_Sloc :=
Sloc (Get_Rep_Pragma (FS, Name_Pack));
Error_Msg_N
("\because of pragma Pack#??", Clause);
end if;
end if;
-- Check for scalar storage order
if Present (Get_Attribute_Definition_Clause
(E, Attribute_Scalar_Storage_Order))
then
Check_Component_Storage_Order (E, Empty);
end if;
-- Processing that is done only for subtypes
else
-- Acquire alignment from base type
if Unknown_Alignment (E) then
Set_Alignment (E, Alignment (Base_Type (E)));
Adjust_Esize_Alignment (E);
end if;
end if;
-- Specific checks for bit-packed arrays
if Is_Bit_Packed_Array (E) then
-- Check number of elements for bit packed arrays that come
-- from source and have compile time known ranges. The
-- bit-packed arrays circuitry does not support arrays
-- with more than Integer'Last + 1 elements, and when this
-- restriction is violated, causes incorrect data access.
-- For the case where this is not compile time known, a
-- run-time check should be generated???
if Comes_From_Source (E) and then Is_Constrained (E) then
declare
Elmts : Uint;
Index : Node_Id;
Ilen : Node_Id;
Ityp : Entity_Id;
begin
Elmts := Uint_1;
Index := First_Index (E);
while Present (Index) loop
Ityp := Etype (Index);
-- Never generate an error if any index is of a
-- generic type. We will check this in instances.
if Is_Generic_Type (Ityp) then
Elmts := Uint_0;
exit;
end if;
Ilen :=
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Ityp, Loc),
Attribute_Name => Name_Range_Length);
Analyze_And_Resolve (Ilen);
-- No attempt is made to check number of elements
-- if not compile time known.
if Nkind (Ilen) /= N_Integer_Literal then
Elmts := Uint_0;
exit;
end if;
Elmts := Elmts * Intval (Ilen);
Next_Index (Index);
end loop;
if Elmts > Intval (High_Bound
(Scalar_Range
(Standard_Integer))) + 1
then
Error_Msg_N
("bit packed array type may not have "
& "more than Integer''Last+1 elements", E);
end if;
end;
end if;
-- Check size
if Known_RM_Size (E) then
declare
SizC : constant Node_Id := Size_Clause (E);
Discard : Boolean;
pragma Warnings (Off, Discard);
begin
-- It is not clear if it is possible to have no 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, RM_Size (E), Discard);
else
Check_Size (E, E, RM_Size (E), Discard);
end if;
end;
end if;
end if;
-- If any of the index types was an enumeration type with a
-- non-standard rep clause, then we indicate that the array
-- type is always packed (even if it is not bit packed).
if Non_Standard_Enum then
Set_Has_Non_Standard_Rep (Base_Type (E));
Set_Is_Packed (Base_Type (E));
end if;
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 Is_Packed (E)
and then Ekind (E) /= E_String_Literal_Subtype
then
Create_Packed_Array_Type (E);
Freeze_And_Append (Packed_Array_Type (E), N, Result);
-- Size information of packed array type is copied to the
-- array type, since this is really the representation. But
-- do not override explicit existing size values. If the
-- ancestor subtype is constrained the packed_array_type
-- will be inherited from it, but the size may have been
-- provided already, and must not be overridden either.
if not Has_Size_Clause (E)
and then
(No (Ancestor_Subtype (E))
or else not Has_Size_Clause (Ancestor_Subtype (E)))
then
Set_Esize (E, Esize (Packed_Array_Type (E)));
Set_RM_Size (E, RM_Size (Packed_Array_Type (E)));
end if;
if not Has_Alignment_Clause (E) then
Set_Alignment (E, Alignment (Packed_Array_Type (E)));
end if;
end if;
-- For non-packed arrays set the alignment of the array to the
-- alignment of the component type if it is unknown. Skip this
-- in atomic case (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 -- For a class-wide type, the corresponding specific type is
-- frozen as well (RM 13.14(15)) -- frozen as well (RM 13.14(15))
......
gcc/ada/sem_ch3.adb
...@@ -1001,7 +1001,7 @@ package body Sem_Ch3 is ...@@ -1001,7 +1001,7 @@ package body Sem_Ch3 is
if Nkind (Def) in N_Has_Etype then if Nkind (Def) in N_Has_Etype then
if Etype (Def) = T_Name then if Etype (Def) = T_Name then
Error_Msg_N Error_Msg_N
("type& cannot be used before end of its declaration", Def); ("typer cannot be used before end of its declaration", Def);
end if; end if;
-- If this is not a subtype, then this is an access_definition -- If this is not a subtype, then this is an access_definition
...@@ -7337,45 +7337,68 @@ package body Sem_Ch3 is ...@@ -7337,45 +7337,68 @@ package body Sem_Ch3 is
and then (Is_Constrained (Parent_Type) or else Constraint_Present) and then (Is_Constrained (Parent_Type) or else Constraint_Present)
then then
-- First, we must analyze the constraint (see comment in point 5.) -- First, we must analyze the constraint (see comment in point 5.)
-- The constraint may come from the subtype indication of the full
-- declaration.
if Constraint_Present then if Constraint_Present then
New_Discrs := Build_Discriminant_Constraints (Parent_Type, Indic); New_Discrs :=
Build_Discriminant_Constraints (Parent_Type, Indic);
if Has_Discriminants (Derived_Type) -- If there is no explicit constraint, there might be one that is
and then Has_Private_Declaration (Derived_Type) -- inherited from a constrained parent type. In that case verify that
and then Present (Discriminant_Constraint (Derived_Type)) -- it conforms to the constraint in the partial view. In perverse
then -- cases the parent subtypes of the partial and full view can have
-- Verify that constraints of the full view statically match -- different constraints.
-- those given in the partial view.
declare elsif Present (Stored_Constraint (Parent_Type)) then
C1, C2 : Elmt_Id; New_Discrs := Stored_Constraint (Parent_Type);
begin else
C1 := First_Elmt (New_Discrs); New_Discrs := No_Elist;
C2 := First_Elmt (Discriminant_Constraint (Derived_Type)); end if;
while Present (C1) and then Present (C2) loop
if Fully_Conformant_Expressions (Node (C1), Node (C2))
or else
(Is_OK_Static_Expression (Node (C1))
and then
Is_OK_Static_Expression (Node (C2))
and then
Expr_Value (Node (C1)) = Expr_Value (Node (C2)))
then
null;
else if Has_Discriminants (Derived_Type)
and then Has_Private_Declaration (Derived_Type)
and then Present (Discriminant_Constraint (Derived_Type))
and then Present (New_Discrs)
then
-- Verify that constraints of the full view statically match
-- those given in the partial view.
declare
C1, C2 : Elmt_Id;
Error_Node : Node_Id;
begin
C1 := First_Elmt (New_Discrs);
C2 := First_Elmt (Discriminant_Constraint (Derived_Type));
while Present (C1) and then Present (C2) loop
if Fully_Conformant_Expressions (Node (C1), Node (C2))
or else
(Is_OK_Static_Expression (Node (C1))
and then
Is_OK_Static_Expression (Node (C2))
and then
Expr_Value (Node (C1)) = Expr_Value (Node (C2)))
then
null;
else
if Constraint_Present then
Error_Msg_N ( Error_Msg_N (
"constraint not conformant to previous declaration", "constraint not conformant to previous declaration",
Node (C1)); Node (C1));
else
Error_Msg_N (
"constraint of full view is incompatible " &
"with partial view", N);
end if; end if;
end if;
Next_Elmt (C1); Next_Elmt (C1);
Next_Elmt (C2); Next_Elmt (C2);
end loop; end loop;
end; end;
end if;
end if; end if;
-- Insert and analyze the declaration for the unconstrained base type -- Insert and analyze the declaration for the unconstrained base type
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment