Patchwork [Ada] Clean up handling of pack, component size, aliased/atomic components

login
register
mail settings
Submitter Arnaud Charlet
Date Oct. 8, 2010, 10:32 a.m.
Message ID <20101008103233.GA10670@adacore.com>
Download mbox | patch
Permalink /patch/67162/
State New
Headers show

Comments

Arnaud Charlet - Oct. 8, 2010, 10:32 a.m.
This patch cleans up the handling of pragma pack, component size clauses
and aliased/atomic components, to catch remaining illegal cases for Ada
2012, and also warn on some redundant packs missed before (now all such
warnings are under control of -gnatwr):

The following is compiled with -gnatwr -gnatj60 -gnatld7

     1. package packcsac is
     2.    type r1 is array (1 .. 3) of boolean;
     3.    pragma Atomic_Components (r1);
     4.    for r1'Component_Size use 2;
           |
        >>> incorrect component size for atomic components,
            only allowed value is 8

     5.
     6.    type r2 is array (1 .. 3) of boolean;
     7.    pragma Atomic_Components (r2);
     8.
     9.    type r3 is array (1 .. 3) of boolean;
    10.    for r3'Component_Size use 2;
           |
        >>> incorrect component size for atomic components,
            only allowed value is 8

    11.    pragma Atomic_Components (r3);
    12.
    13.    type r4 is array (1 .. 3) of boolean;
    14.    pragma Pack (r4);
           |
        >>> warning: pragma Pack for "r4" ignored, explicit
            component size given at line 15

    15.    for r4'Component_Size use 2;
    16.
    17.    type r6 is array (1 .. 3) of boolean;
    18.    for r6'Component_Size use 2;
    19.    pragma Pack (r6);
           |
        >>> warning: pragma Pack for "r6" ignored, explicit
            component size given at line 18

    20.
    21.    type r7 is array (1 .. 3) of boolean;
    22.    pragma Atomic_Components (r7);
    23.    pragma Pack (r7);
           |
        >>> cannot pack atomic components

    24.
    25.    type r8 is array (1 .. 3) of boolean;
    26.    pragma Pack (r8);
           |
        >>> cannot pack atomic components

    27.    pragma Atomic_Components (r8);
    28.
    29.    type R9 is array (1 .. 32) of boolean;
    30.    pragma Pack (R9);
    31.    pragma Atomic (R9);
           |
        >>> warning: non-atomic components of type "r9" may
            not be accessible by separate tasks, because of
            pragma Pack at line 30

    32.
    33.    type R10 is array (1 .. 32) of boolean;
    34.    pragma Atomic (R10);
           |
        >>> warning: non-atomic components of type "r10"
            may not be accessible by separate tasks,
            because of pragma Pack at line 35

    35.    pragma Pack (R10);
    36.
    37.    type R11 is array (1 .. 32) of boolean;
    38.    for R11'Component_Size use 1;
    39.    pragma Atomic (R11);
           |
        >>> warning: non-atomic components of type "r11"
            may not be accessible by separate tasks,
            because of component size clause at line 38

    40.
    41.    type R12 is array (1 .. 32) of boolean;
    42.    pragma Atomic (R12);
           |
        >>> warning: non-atomic components of type "r12"
            may not be accessible by separate tasks,
            because of component size clause at line 43

    43.    for R12'Component_Size use 1;
    44.
    45.    type R13 is array (1 .. 4) of Character;
    46.    pragma Atomic (R13);
    47.    for R13'Component_Size use 8;
    48. end;

This patch also corrects an error introduced by a previous recent
patch in this area which caused a regression on handling of
aliased components. The following must compile clean:

package Pkg is
  subtype SEM_OP_FLAGS_TYPE is Interfaces.C.short;

  type SEM_INDEX_TYPE is (VALUE, COUNT, LOCK);

    for SEM_INDEX_TYPE'SIZE use 16;

  type SEMBUF_TYPE is
    record
      SEM_NUM : SEM_INDEX_TYPE     := VALUE;  -- semaphore number
      SEM_OP  : Interfaces.C.short := 0;  -- semaphore operation value
      SEM_FLG : SEM_OP_FLAGS_TYPE  := 0;  -- operation flags
    end record;
    for SEMBUF_TYPE'SIZE use 48;

  type SEMOPS_TYPE is array (POSITIVE range <>) of aliased SEMBUF_TYPE;
    for SEMOPS_TYPE'COMPONENT_SIZE use 48;
end Pkg;

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-10-08  Robert Dewar  <dewar@adacore.com>

	* freeze.adb (Freeze_Entity): For array case, move some processing for
	pragma Pack, Component_Size clause and atomic/volatile components here
	instead of trying to do the job in Sem_Ch13 and Freeze.
	* layout.adb: Use new Addressable function
	* sem_ch13.adb (Analyze_Attribute_Representation_Clause, case
	Component_Size): Move some handling to freeze point in
	Freeze.Freeze_Entity.
	* sem_prag.adb (Analyze_pragma, case Pack): Move some handling to
	freeze point in Freese.Freeze_Entity.
	* sem_util.ads, sem_util.adb (Addressable): New function.

Patch

Index: layout.adb
===================================================================
--- layout.adb	(revision 165080)
+++ layout.adb	(working copy)
@@ -2568,14 +2568,9 @@  package body Layout is
                then
                   declare
                      S : constant Uint := Esize (CT);
-
                   begin
-                     if S = 8  or else
-                        S = 16 or else
-                        S = 32 or else
-                        S = 64
-                     then
-                        Set_Component_Size (E, Esize (CT));
+                     if Addressable (S) then
+                        Set_Component_Size (E, S);
                      end if;
                   end;
                end if;
Index: sem_prag.adb
===================================================================
--- sem_prag.adb	(revision 165156)
+++ sem_prag.adb	(working copy)
@@ -5928,7 +5928,6 @@  package body Sem_Prag is
             E    : Entity_Id;
             D    : Node_Id;
             K    : Node_Kind;
-            Ctyp : Entity_Id;
 
          begin
             Check_Ada_83_Warning;
@@ -5970,24 +5969,6 @@  package body Sem_Prag is
 
                if Prag_Id = Pragma_Atomic_Components then
                   Set_Has_Atomic_Components (E);
-
-                  if Is_Packed (E) then
-                     Set_Is_Packed (E, False);
-
-                     if Is_Array_Type (E) then
-                        Ctyp := Component_Type (E);
-                     else
-                        Ctyp := Component_Type (Etype (E));
-                     end if;
-
-                     if not (Known_Static_Esize (Ctyp)
-                              and then Known_Static_RM_Size (Ctyp)
-                              and then Esize (Ctyp) = RM_Size (Ctyp))
-                     then
-                        Error_Pragma_Arg
-                          ("cannot pack atomic components", Arg1);
-                     end if;
-                  end if;
                end if;
 
             else
@@ -8091,9 +8072,9 @@  package body Sem_Prag is
             Record_Rep_Item (Proc_Id, N);
          end Implemented;
 
-         -----------------------
+         ----------------------
          -- Implicit_Packing --
-         -----------------------
+         ----------------------
 
          --  pragma Implicit_Packing;
 
@@ -9991,76 +9972,40 @@  package body Sem_Prag is
                if Known_Static_Esize (Ctyp)
                  and then Known_Static_RM_Size (Ctyp)
                  and then Esize (Ctyp) = RM_Size (Ctyp)
-                 and then (Esize (Ctyp) = 8  or else
-                           Esize (Ctyp) = 16 or else
-                           Esize (Ctyp) = 32 or else
-                           Esize (Ctyp) = 64)
+                 and then Addressable (Esize (Ctyp))
                then
                   Ignore := True;
-
-               --  Pack not allowed for aliased/atomic components
-
-               elsif Has_Aliased_Components (Base_Type (Typ)) then
-                  Error_Pragma ("cannot pack aliased components");
-
-               elsif Has_Atomic_Components (Typ)
-                 or else Is_Atomic (Component_Type (Typ))
-               then
-                  Error_Pragma ("cannot pack atomic components");
-
-               --  Warn for cases of packing non-atomic components of atomic
-
-               elsif Is_Atomic (Typ) then
-                  Error_Msg_NE
-                    ("non-atomic components of type& may not be accessible "
-                     & "by separate tasks?", N, Typ);
                end if;
 
-               --  If we had an explicit component size given, then we do not
-               --  let Pack override this given size. We also give a warning
-               --  that Pack is being ignored unless we can tell for sure that
-               --  the Pack would not have had any effect anyway.
-
-               if Has_Component_Size_Clause (Typ) then
-                  if Known_Static_RM_Size (Component_Type (Typ))
-                    and then
-                      RM_Size (Component_Type (Typ)) = Component_Size (Typ)
-                  then
-                     null;
-                  else
-                     Error_Pragma
-                       ("?pragma% ignored, explicit component size given");
-                  end if;
-
-               --  If no prior array component size given, Pack is effective
+               --  Process OK pragma Pack. Note that if there is a separate
+               --  component clause present, the Pack will be cancelled. This
+               --  processing is in Freeze.
 
-               else
-                  if not Rep_Item_Too_Late (Typ, N) then
+               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.
+                  --  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
-                        null;
+                  if CodePeer_Mode then
+                     null;
 
-                     --  For normal non-VM target, do the packing
+                  --  For normal non-VM target, do the packing
 
-                     elsif VM_Target = No_VM then
-                        if not Ignore then
-                           Set_Is_Packed            (Base_Type (Typ));
-                           Set_Has_Non_Standard_Rep (Base_Type (Typ));
-                        end if;
+                  elsif VM_Target = No_VM then
+                     if not Ignore then
+                        Set_Is_Packed            (Base_Type (Typ));
+                        Set_Has_Non_Standard_Rep (Base_Type (Typ));
+                     end if;
 
-                        Set_Has_Pragma_Pack      (Base_Type (Typ));
+                     Set_Has_Pragma_Pack (Base_Type (Typ));
 
-                     --  If we ignore the pack for VM_Targets, then warn about
-                     --  this, except suppress the warning in GNAT mode.
+                  --  If we ignore the pack for VM_Targets, then warn about
+                  --  this, except suppress the warning in GNAT mode.
 
-                     elsif not GNAT_Mode then
-                        Error_Pragma
-                          ("?pragma% ignored in this configuration");
-                     end if;
+                  elsif not GNAT_Mode then
+                     Error_Pragma
+                       ("?pragma% ignored in this configuration");
                   end if;
                end if;
 
Index: freeze.adb
===================================================================
--- freeze.adb	(revision 165081)
+++ freeze.adb	(working copy)
@@ -3097,7 +3097,9 @@  package body Freeze is
 
          if Is_Array_Type (E) then
             declare
-               Ctyp : constant Entity_Id := Component_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
@@ -3150,8 +3152,8 @@  package body Freeze is
 
                   begin
                      if (Is_Packed (E) or else Has_Pragma_Pack (E))
-                       and then not Has_Atomic_Components (E)
                        and then Known_Static_RM_Size (Ctyp)
+                       and then not Has_Component_Size_Clause (E)
                      then
                         Csiz := UI_Max (RM_Size (Ctyp), 1);
 
@@ -3213,6 +3215,7 @@  package body Freeze is
 
                            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
@@ -3221,6 +3224,8 @@  package body Freeze is
                               Error_Msg_N
                                 ("\?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
@@ -3277,19 +3282,129 @@  package body Freeze is
                               --  a representation characteristic, and this
                               --  request may be ignored.
 
-                              Set_Is_Packed (Base_Type (E), False);
+                              Set_Is_Packed           (Base_Type (E), False);
+                              Set_Is_Bit_Packed_Array (Base_Type (E), False);
 
-                              --  In all other cases, packing is indeed needed
+                              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));
-                              Set_Is_Bit_Packed_Array  (Base_Type (E));
-                              Set_Is_Packed            (Base_Type (E));
+                              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
+                        --  Case where component size has no effect
+
+                        if Known_Static_Esize (Ctyp)
+                          and then Known_Static_RM_Size (Ctyp)
+                          and then Esize (Ctyp) = RM_Size (Ctyp)
+                          and then Esize (Ctyp) mod 8 = 0
+                        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;
+
                --  Processing that is done only for subtypes
 
                else
@@ -4749,11 +4864,7 @@  package body Freeze is
                --  natural boundary of size.
 
                elsif Size_Incl_EP /= Size_Excl_EP
-                 and then
-                    (Size_Excl_EP = 8  or else
-                     Size_Excl_EP = 16 or else
-                     Size_Excl_EP = 32 or else
-                     Size_Excl_EP = 64)
+                 and then Addressable (Size_Excl_EP)
                then
                   Actual_Size := Size_Excl_EP;
                   Actual_Lo   := Loval_Excl_EP;
Index: sem_util.adb
===================================================================
--- sem_util.adb	(revision 165155)
+++ sem_util.adb	(working copy)
@@ -245,6 +245,28 @@  package body Sem_Util is
       Analyze (N);
    end Add_Global_Declaration;
 
+   -----------------
+   -- Addressable --
+   -----------------
+
+   --  For now, just 8/16/32/64. but analyze later if AAMP is special???
+
+   function Addressable (V : Uint) return Boolean is
+   begin
+      return V = Uint_8  or else
+             V = Uint_16 or else
+             V = Uint_32 or else
+             V = Uint_64;
+   end Addressable;
+
+   function Addressable (V : Int) return Boolean is
+   begin
+      return V = 8  or else
+             V = 16 or else
+             V = 32 or else
+             V = 64;
+   end Addressable;
+
    -----------------------
    -- Alignment_In_Bits --
    -----------------------
Index: sem_util.ads
===================================================================
--- sem_util.ads	(revision 165154)
+++ sem_util.ads	(working copy)
@@ -51,6 +51,12 @@  package Sem_Util is
    --  for the current unit. The declarations are added in the current scope,
    --  so the caller should push a new scope as required before the call.
 
+   function Addressable (V : Uint) return Boolean;
+   function Addressable (V : Int)  return Boolean;
+   pragma Inline (Addressable);
+   --  Returns True if the value of V is the word size of an addressable
+   --  factor of the word size (typically 8, 16, 32 or 64).
+
    function Alignment_In_Bits (E : Entity_Id) return Uint;
    --  If the alignment of the type or object E is currently known to the
    --  compiler, then this function returns the alignment value in bits.
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb	(revision 165110)
+++ sem_ch13.adb	(working copy)
@@ -1298,34 +1298,6 @@  package body Sem_Ch13 is
             Biased   : Boolean;
             New_Ctyp : Entity_Id;
             Decl     : Node_Id;
-            Ignore   : Boolean := False;
-
-            procedure Complain_CS (T : String);
-            --  Outputs error messages for incorrect CS clause for aliased or
-            --  atomic components (T is "aliased" or "atomic");
-
-            -----------------
-            -- Complain_CS --
-            -----------------
-
-            procedure Complain_CS (T : String) is
-            begin
-               if Known_Static_Esize (Ctyp) then
-                  Error_Msg_N
-                    ("incorrect component size for " & T & " components", N);
-                  Error_Msg_Uint_1 := Esize (Ctyp);
-                  Error_Msg_N ("\only allowed value is^", N);
-
-               else
-                  Error_Msg_N
-                    ("component size cannot be given for " & T & " components",
-                     N);
-               end if;
-
-               return;
-            end Complain_CS;
-
-         --  Start of processing for Component_Size_Case
 
          begin
             if not Is_Array_Type (U_Ent) then
@@ -1340,41 +1312,12 @@  package body Sem_Ch13 is
                Error_Msg_N
                  ("component size clause for& previously given", Nam);
 
+            elsif Rep_Item_Too_Early (Btype, N) then
+               null;
+
             elsif Csize /= No_Uint then
                Check_Size (Expr, Ctyp, Csize, Biased);
 
-               --  Case where component size has no effect
-
-               if Known_Static_Esize (Ctyp)
-                 and then Known_Static_RM_Size (Ctyp)
-                 and then Esize (Ctyp) = RM_Size (Ctyp)
-                 and then (Esize (Ctyp) = 8  or else
-                           Esize (Ctyp) = 16 or else
-                           Esize (Ctyp) = 32 or else
-                           Esize (Ctyp) = 64)
-               then
-                  Ignore := True;
-
-               --  Cannot give component size for aliased/atomic components
-
-               elsif Has_Aliased_Components (Btype)
-                 or else Is_Aliased (Ctyp)
-               then
-                  Complain_CS ("aliased");
-
-               elsif Has_Atomic_Components (Btype)
-                  or else Is_Atomic (Ctyp)
-               then
-                  Complain_CS ("atomic");
-
-               --  Warn for case of atomic type
-
-               elsif Is_Atomic (Btype) then
-                  Error_Msg_NE
-                    ("non-atomic components of type& may not be accessible "
-                     & "by separate tasks?", N, Btype);
-               end if;
-
                --  For the biased case, build a declaration for a subtype
                --  that will be used to represent the biased subtype that
                --  reflects the biased representation of components. We need
@@ -1435,10 +1378,7 @@  package body Sem_Ch13 is
                end if;
 
                Set_Has_Component_Size_Clause (Btype, True);
-
-               if not Ignore then
-                  Set_Has_Non_Standard_Rep (Btype, True);
-               end if;
+               Set_Has_Non_Standard_Rep (Btype, True);
             end if;
          end Component_Size_Case;