-- integer literal without an explicit corresponding size clause. The
-- 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;
-- Create Freeze_Generic_Entity nodes for types declared in a generic
-- package. Recurse on inner generic packages.
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.
-------------------
end if;
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_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
-- sized type. We have to delay this test till this point,
-- since the component type has to be frozen for us to know
Inherit_Aspects_At_Freeze_Point (E);
end if;
- -- For array type, freeze index types and component type first
- -- before freezing the array (RM 13.14(15)).
+ -- Array type
if Is_Array_Type (E) then
- declare
- 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;
+ Freeze_Array_Type (E);
-- For a class-wide type, the corresponding specific type is
-- frozen as well (RM 13.14(15))
projects / platform / upstream / linaro-gcc.git / commitdiff