+2013-10-15 Thomas Quinot <quinot@adacore.com>
+
+ * exp_pakd.adb (Expand_Packed_Element_Set,
+ Expand_Packed_Element_Reference): Adjust for the case of packed
+ arrays of reverse-storage-order types.
+
+2013-10-15 Robert Dewar <dewar@adacore.com>
+
+ * sem_prag.adb: Minor reformatting.
+
+2013-10-15 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute_Specification, case
+ To_Address): If the expression is an identifier, do not modify
+ its type; it will be converted when necessary, and the type of
+ the expression must remain consistent with that of the entity
+ for back-end consistency.
+
+2013-10-15 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch7.adb (Unit_Requires_Body): Add flag
+ Ignore_Abstract_State (Analyze_Package_Specification): Enforce
+ rule requiring Elaborate_Body if a non-null abstract state is
+ specified for a library-level package.
+ * sem_ch7.ads (Unit_Requires_Body): Add flag Ignore_Abstract_State.
+
2013-10-15 Hristian Kirtchev <kirtchev@adacore.com>
* sem_prag.adb (Analyze_Constituent): When
-- array type on the fly). Such actions are inserted into the tree
-- directly using Insert_Action.
- function Byte_Swap (N : Node_Id) return Node_Id;
+ function Byte_Swap
+ (N : Node_Id;
+ Left_Justify : Boolean := False;
+ Right_Justify : Boolean := False) return Node_Id;
-- Wrap N in a call to a byte swapping function, with appropriate type
- -- conversions.
+ -- conversions. If Left_Justify is set True, the value is left justified
+ -- before swapping. If Right_Justify is set True, the value is right
+ -- justified after swapping. The Etype of the returned node is an
+ -- integer type of an appropriate power-of-2 size.
---------------
-- Byte_Swap --
---------------
- function Byte_Swap (N : Node_Id) return Node_Id is
+ function Byte_Swap
+ (N : Node_Id;
+ Left_Justify : Boolean := False;
+ Right_Justify : Boolean := False) return Node_Id
+ is
Loc : constant Source_Ptr := Sloc (N);
T : constant Entity_Id := Etype (N);
+ T_Size : constant Uint := RM_Size (T);
+
Swap_RE : RE_Id;
Swap_F : Entity_Id;
+ Swap_T : Entity_Id;
+ -- Swapping function
+
+ Arg : Node_Id;
+ Swapped : Node_Id;
+ Shift : Uint;
begin
- pragma Assert (Esize (T) > 8);
+ pragma Assert (T_Size > 8);
- if Esize (T) <= 16 then
+ if T_Size <= 16 then
Swap_RE := RE_Bswap_16;
- elsif Esize (T) <= 32 then
+
+ elsif T_Size <= 32 then
Swap_RE := RE_Bswap_32;
- else pragma Assert (Esize (T) <= 64);
+
+ else pragma Assert (T_Size <= 64);
Swap_RE := RE_Bswap_64;
end if;
Swap_F := RTE (Swap_RE);
+ Swap_T := Etype (Swap_F);
+ Shift := Esize (Swap_T) - T_Size;
+
+ Arg := RJ_Unchecked_Convert_To (Swap_T, N);
+
+ if Left_Justify and then Shift > Uint_0 then
+ Arg :=
+ Make_Op_Shift_Left (Loc,
+ Left_Opnd => Arg,
+ Right_Opnd => Make_Integer_Literal (Loc, Shift));
+ end if;
+
+ Swapped :=
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Swap_F, Loc),
+ Parameter_Associations => New_List (Arg));
+
+ if Right_Justify and then Shift > Uint_0 then
+ Swapped :=
+ Make_Op_Shift_Right (Loc,
+ Left_Opnd => Swapped,
+ Right_Opnd => Make_Integer_Literal (Loc, Shift));
+ end if;
- return
- Unchecked_Convert_To (T,
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Swap_F, Loc),
- Parameter_Associations =>
- New_List (Unchecked_Convert_To (Etype (Swap_F), N))));
+ Set_Etype (Swapped, Swap_T);
+ return Swapped;
end Byte_Swap;
------------------------------
and then not In_Reverse_Storage_Order_Object (Obj)
then
Require_Byte_Swapping := True;
- New_Rhs := Byte_Swap (New_Rhs);
+ New_Rhs := Byte_Swap (New_Rhs,
+ Left_Justify => Bytes_Big_Endian,
+ Right_Justify => not Bytes_Big_Endian);
end if;
end;
-- not a left justified conversion.
Rhs := RJ_Unchecked_Convert_To (Etype (Obj), Rhs);
-
end Fixup_Rhs;
begin
if Nkind (New_Rhs) = N_Op_And then
Set_Paren_Count (New_Rhs, 1);
+ Set_Etype (New_Rhs, Etype (Left_Opnd (New_Rhs)));
end if;
New_Rhs :=
Make_Op_Or (Loc,
Left_Opnd => New_Rhs,
- Right_Opnd => Or_Rhs);
+ Right_Opnd => Unchecked_Convert_To
+ (Etype (New_Rhs), Or_Rhs));
end;
end if;
if Require_Byte_Swapping then
Set_Etype (New_Rhs, Etype (Obj));
- New_Rhs := Byte_Swap (New_Rhs);
+ New_Rhs :=
+ Unchecked_Convert_To (Etype (Obj),
+ Byte_Swap (New_Rhs,
+ Left_Justify => not Bytes_Big_Endian,
+ Right_Justify => Bytes_Big_Endian));
end if;
-- Now do the rewrite
Lit : Node_Id;
Arg : Node_Id;
+ Byte_Swapped : Boolean;
+ -- Set true if bytes were swapped for the purpose of extracting the
+ -- element, in which case we must swap back if the component type is
+ -- a composite type with reverse scalar storage order.
+
begin
-- If the node is an actual in a call, the prefix has not been fully
-- expanded, to account for the additional expansion for in-out actuals
and then Esize (Atyp) > 8
and then not In_Reverse_Storage_Order_Object (Obj)
then
- Obj := Byte_Swap (Obj);
+ Obj := Byte_Swap (Obj,
+ Left_Justify => Bytes_Big_Endian,
+ Right_Justify => not Bytes_Big_Endian);
+ Byte_Swapped := True;
+
+ else
+ Byte_Swapped := False;
end if;
-- We generate a shift right to position the field, followed by a
Left_Opnd => Make_Shift_Right (Obj, Shift),
Right_Opnd => Lit);
+ -- Swap back if necessary
+
+ Set_Etype (Arg, Ctyp);
+ if Byte_Swapped and then Reverse_Storage_Order (Ctyp) then
+ Arg := Byte_Swap (Arg,
+ Left_Justify => not Bytes_Big_Endian,
+ Right_Justify => False);
+ end if;
+
-- We needed to analyze this before we do the unchecked convert
-- below, but we need it temporarily attached to the tree for
-- this analysis (hence the temporary Set_Parent call).
Source_Siz := UI_To_Int (RM_Size (Source_Typ));
Target_Siz := UI_To_Int (RM_Size (Target_Typ));
+ -- For a little-endian target type stored byte-swapped on a
+ -- big-endian machine, do not mask to Target_Siz bits.
+
+ if Bytes_Big_Endian
+ and then (Is_Record_Type (Target_Typ)
+ or else
+ Is_Array_Type (Target_Typ))
+ and then Reverse_Storage_Order (Target_Typ)
+ then
+ Source_Siz := Target_Siz;
+ end if;
+
-- First step, if the source type is not a discrete type, then we first
-- convert to a modular type of the source length, since otherwise, on
-- a big-endian machine, we get left-justification. We do it for little-
Clear_Constants (Id, First_Private_Entity (Id));
end if;
+ -- Issue an error in SPARK mode if a package specification contains
+ -- more than one tagged type or type extension.
+
Check_One_Tagged_Type_Or_Extension_At_Most;
+
+ -- Issue an error if a package that is a library unit does not require a
+ -- body, and we have a non-null abstract state (SPARK LRM 7.1.5(4)).
+
+ if not Unit_Requires_Body (Id, Ignore_Abstract_State => True)
+ and then Present (Abstract_States (Id))
+
+ -- We use Scope_Depth of 1 to identify library units, which seems a
+ -- bit ugly, but there doesn't seem to be an easier way.
+
+ and then Scope_Depth (Id) = 1
+
+ -- A null abstract state always appears as the sole element of the
+ -- state list.
+
+ and then not Is_Null_State (Node (First_Elmt (Abstract_States (Id))))
+ then
+ declare
+ P : constant Node_Id := Get_Pragma (Id, Pragma_Abstract_State);
+ begin
+ Error_Msg_NE
+ ("package & specifies a non-null abstract state", P, Id);
+ Error_Msg_N
+ ("\but package does not otherwise require a body", P);
+ Error_Msg_N
+ ("\pragma Elaborate_Body is required in this case", P);
+ end;
+ end if;
end Analyze_Package_Specification;
--------------------------------------
-- Unit_Requires_Body --
------------------------
- function Unit_Requires_Body (P : Entity_Id) return Boolean is
+ function Unit_Requires_Body
+ (P : Entity_Id;
+ Ignore_Abstract_State : Boolean := False) return Boolean
+ is
E : Entity_Id;
begin
end;
-- A [generic] package that introduces at least one non-null abstract
- -- state requires completion. A null abstract state always appears as
- -- the sole element of the state list.
+ -- state requires completion. However, there is a separate rule that
+ -- requires that such a package have a reason other than this for a
+ -- body being required (if necessary a pragma Elaborate_Body must be
+ -- provided). If Ignore_Abstract_State is True, we don't do this check
+ -- (so we can use Unit_Requires_Body to check for some other reason).
elsif Ekind_In (P, E_Generic_Package, E_Package)
+ and then not Ignore_Abstract_State
and then Present (Abstract_States (P))
- and then not Is_Null_State (Node (First_Elmt (Abstract_States (P))))
+ and then
+ not Is_Null_State (Node (First_Elmt (Abstract_States (P))))
then
return True;
end if;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- but is deferred until the compilation of the private part of the
-- child for public child packages.
- function Unit_Requires_Body (P : Entity_Id) return Boolean;
- -- Check if a unit requires a body. A specification requires a body
- -- if it contains declarations that require completion in a body.
+ function Unit_Requires_Body
+ (P : Entity_Id;
+ Ignore_Abstract_State : Boolean := False) return Boolean;
+ -- Check if a unit requires a body. A specification requires a body if it
+ -- contains declarations that require completion in a body. If the flag
+ -- Ignore_Abstract_State is set True, then the test for a non-null abstract
+ -- state (which normally requires a body) is not carried out. This allows
+ -- the use of this routine to tell if there is some other reason that a
+ -- body is required (as is required for analyzing Abstract_State).
procedure May_Need_Implicit_Body (E : Entity_Id);
-- If a package declaration contains tasks or RACWs and does not require
projects / gcc.git / commitdiff