2007-08-14 Robert Dewar <dewar@adacore.com>
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 14 Aug 2007 08:39:20 +0000 (08:39 +0000)
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 14 Aug 2007 08:39:20 +0000 (08:39 +0000)
    Ed Schonberg  <schonberg@adacore.com>
    Javier Miranda  <miranda@adacore.com>

* exp_util.ads, exp_util.adb:
This patch replaces a number of occurrences of explicit tests for N_Null
with calls to Known_Null. This improves tracking of null values, since
Known_Null also catches null constants, and variables currently known to
be null, so we get better tracking.
(Ensure_Defined): create an itype reference only in the scope of the
itype.
(Side_Effect_Free): A selected component of an access type that
denotes a component with a rep clause must be treated as not
side-effect free, because if it is part of a linked structure its
value may be affected by a renaming.
(Expand_Subtype_From_Expr): For limited objects initialized with build
in place function calls, do nothing; otherwise we prematurely introduce
an N_Reference node in the expression initializing the object, which
breaks the circuitry that detects and adds the additional arguments to
the called function. Bug found working in the new patch for statically
allocated dispatch tables.
(Is_Library_Level_Tagged_Type): New subprogram.
(Remove_Side_Effects): If the expression of an elementary type is an
operator treat as a function call.
(Make_Literal_Range): If the index type of the array is not integer, use
attributes properly to compute the constraint on the resulting aggregate
which is a string.

* freeze.ads, freeze.adb (Freeze_Entity): If the entity is a
class-wide type whose base type is an incomplete private type, leave
class-wide type unfrozen so that freeze nodes can be generated
properly at a later point.
(Freeze_Entity, array case): Handle case of pragma Pack and component
size attributre clause for same array.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@127419 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/ada/exp_util.adb
gcc/ada/exp_util.ads
gcc/ada/freeze.adb
gcc/ada/freeze.ads

index 93798b3..0f84960 100644 (file)
@@ -31,6 +31,7 @@ with Einfo;    use Einfo;
 with Elists;   use Elists;
 with Errout;   use Errout;
 with Exp_Aggr; use Exp_Aggr;
+with Exp_Ch6;  use Exp_Ch6;
 with Exp_Ch7;  use Exp_Ch7;
 with Inline;   use Inline;
 with Itypes;   use Itypes;
@@ -89,8 +90,8 @@ package body Exp_Util is
        Pos    : out Entity_Id;
        Prefix : Entity_Id;
        Sum    : Node_Id;
-       Decls  : in out List_Id;
-       Stats  : in out List_Id);
+       Decls  : List_Id;
+       Stats  : List_Id);
    --  Common processing for Task_Array_Image and Task_Record_Image.
    --  Create local variables and assign prefix of name to result string.
 
@@ -125,8 +126,14 @@ package body Exp_Util is
       Literal_Typ : Entity_Id) return Node_Id;
    --  Produce a Range node whose bounds are:
    --    Low_Bound (Literal_Type) ..
-   --        Low_Bound (Literal_Type) + Length (Literal_Typ) - 1
+   --        Low_Bound (Literal_Type) + (Length (Literal_Typ) - 1)
    --  this is used for expanding declarations like X : String := "sdfgdfg";
+   --
+   --  If the index type of the target array is not integer, we generate:
+   --     Low_Bound (Literal_Type) ..
+   --        Literal_Type'Val
+   --          (Literal_Type'Pos (Low_Bound (Literal_Type))
+   --             + (Length (Literal_Typ) -1))
 
    function New_Class_Wide_Subtype
      (CW_Typ : Entity_Id;
@@ -400,8 +407,8 @@ package body Exp_Util is
       T : Entity_Id;
       --  Entity for name at one index position
 
-      Decls : List_Id := New_List;
-      Stats : List_Id := New_List;
+      Decls : constant List_Id := New_List;
+      Stats : constant List_Id := New_List;
 
    begin
       Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
@@ -680,7 +687,7 @@ package body Exp_Util is
 
    begin
       Append_To (Stats,
-        Make_Return_Statement (Loc,
+        Make_Simple_Return_Statement (Loc,
           Expression => New_Occurrence_Of (Res, Loc)));
 
       Spec := Make_Function_Specification (Loc,
@@ -709,8 +716,8 @@ package body Exp_Util is
        Pos    : out Entity_Id;
        Prefix : Entity_Id;
        Sum    : Node_Id;
-       Decls  : in out List_Id;
-       Stats  : in out List_Id)
+       Decls  : List_Id;
+       Stats  : List_Id)
    is
    begin
       Len := Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
@@ -805,8 +812,8 @@ package body Exp_Util is
       Sel : Entity_Id;
       --  Entity for selector name
 
-      Decls : List_Id := New_List;
-      Stats : List_Id := New_List;
+      Decls : constant List_Id := New_List;
+      Stats : constant List_Id := New_List;
 
    begin
       Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
@@ -1052,36 +1059,17 @@ package body Exp_Util is
 
    procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
       IR : Node_Id;
-      P  : Node_Id;
 
    begin
-      if Is_Itype (Typ) then
+      --  An itype reference must only be created if this is a local
+      --  itype, so that gigi can elaborate it on the proper objstack.
+
+      if Is_Itype (Typ)
+        and then  Scope (Typ) = Current_Scope
+      then
          IR := Make_Itype_Reference (Sloc (N));
          Set_Itype (IR, Typ);
-
-         if not In_Open_Scopes (Scope (Typ))
-           and then Is_Subprogram (Current_Scope)
-           and then Scope (Current_Scope) /= Standard_Standard
-         then
-            --  Insert node in front of subprogram, to avoid scope anomalies
-            --  in gigi.
-
-            P := Parent (N);
-            while Present (P)
-              and then Nkind (P) /= N_Subprogram_Body
-            loop
-               P := Parent (P);
-            end loop;
-
-            if Present (P) then
-               Insert_Action (P, IR);
-            else
-               Insert_Action (N, IR);
-            end if;
-
-         else
-            Insert_Action (N, IR);
-         end if;
+         Insert_Action (N, IR);
       end if;
    end Ensure_Defined;
 
@@ -1318,6 +1306,15 @@ package body Exp_Util is
       then
          null;
 
+      --  For limited objects initialized with build in place function calls,
+      --  nothing to be done; otherwise we prematurely introduce an N_Reference
+      --  node in the expression initializing the object, which breaks the
+      --  circuitry that detects and adds the additional arguments to the
+      --  called function.
+
+      elsif Is_Build_In_Place_Function_Call (Exp) then
+         null;
+
       else
          Remove_Side_Effects (Exp);
          Rewrite (Subtype_Indic,
@@ -2948,6 +2945,16 @@ package body Exp_Util is
       return True;
    end Is_All_Null_Statements;
 
+   ----------------------------------
+   -- Is_Library_Level_Tagged_Type --
+   ----------------------------------
+
+   function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean is
+   begin
+      return Is_Tagged_Type (Typ)
+        and then Is_Library_Level_Entity (Typ);
+   end Is_Library_Level_Tagged_Type;
+
    -----------------------------------------
    -- Is_Predefined_Dispatching_Operation --
    -----------------------------------------
@@ -3386,7 +3393,7 @@ package body Exp_Util is
 
          if Warn then
             Error_Msg_F
-              ("?this code can never be executed and has been deleted", N);
+              ("?this code can never be executed and has been deleted!", N);
          end if;
 
          --  Recurse into block statements and bodies to process declarations
@@ -3514,7 +3521,7 @@ package body Exp_Util is
 
             Get_Current_Value_Condition (N, Op, Val);
 
-            if Nkind (Val) = N_Null then
+            if Known_Null (Val) then
                if Op = N_Op_Eq then
                   return False;
                elsif Op = N_Op_Ne then
@@ -3578,11 +3585,19 @@ package body Exp_Util is
             Val : Node_Id;
 
          begin
+            --  Constant null value is for sure null
+
+            if Ekind (E) = E_Constant
+              and then Known_Null (Constant_Value (E))
+            then
+               return True;
+            end if;
+
             --  First check if we are in decisive conditional
 
             Get_Current_Value_Condition (N, Op, Val);
 
-            if Nkind (Val) = N_Null then
+            if Known_Null (Val) then
                if Op = N_Op_Eq then
                   return True;
                elsif Op = N_Op_Ne then
@@ -3797,25 +3812,46 @@ package body Exp_Util is
      (Loc         : Source_Ptr;
       Literal_Typ : Entity_Id) return Node_Id
    is
-      Lo : constant Node_Id :=
-             New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
+      Lo          : constant Node_Id :=
+                      New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
+      Index       : constant Entity_Id := Etype (Lo);
+
+      Hi          : Node_Id;
+      Length_Expr : constant Node_Id :=
+                      Make_Op_Subtract (Loc,
+                        Left_Opnd =>
+                          Make_Integer_Literal (Loc,
+                            Intval => String_Literal_Length (Literal_Typ)),
+                        Right_Opnd =>
+                          Make_Integer_Literal (Loc, 1));
 
    begin
       Set_Analyzed (Lo, False);
 
+         if Is_Integer_Type (Index) then
+            Hi :=
+              Make_Op_Add (Loc,
+                Left_Opnd  => New_Copy_Tree (Lo),
+                Right_Opnd => Length_Expr);
+         else
+            Hi :=
+              Make_Attribute_Reference (Loc,
+                Attribute_Name => Name_Val,
+                Prefix => New_Occurrence_Of (Index, Loc),
+                Expressions => New_List (
+                 Make_Op_Add (Loc,
+                   Left_Opnd =>
+                     Make_Attribute_Reference (Loc,
+                       Attribute_Name => Name_Pos,
+                       Prefix => New_Occurrence_Of (Index, Loc),
+                       Expressions => New_List (New_Copy_Tree (Lo))),
+                  Right_Opnd => Length_Expr)));
+         end if;
+
          return
            Make_Range (Loc,
-             Low_Bound => Lo,
-
-             High_Bound =>
-               Make_Op_Subtract (Loc,
-                  Left_Opnd =>
-                    Make_Op_Add (Loc,
-                      Left_Opnd  => New_Copy_Tree (Lo),
-                      Right_Opnd =>
-                        Make_Integer_Literal (Loc,
-                          String_Literal_Length (Literal_Typ))),
-                  Right_Opnd => Make_Integer_Literal (Loc, 1)));
+             Low_Bound  => Lo,
+             High_Bound => Hi);
    end Make_Literal_Range;
 
    ----------------------------
@@ -4401,10 +4437,23 @@ package body Exp_Util is
                return Side_Effect_Free (Expression (N));
 
             --  A selected component is side effect free only if it is a
-            --  side effect free prefixed reference.
+            --  side effect free prefixed reference. If it designates a
+            --  component with a rep. clause it must be treated has having
+            --  a potential side effect, because it may be modified through
+            --  a renaming, and a subsequent use of the renaming as a macro
+            --  will yield the wrong value. This complex interaction between
+            --  renaming and removing side effects is a reminder that the
+            --  latter has become a headache to maintain, and that it should
+            --  be removed in favor of the gcc mechanism to capture values ???
 
             when N_Selected_Component =>
-               return Safe_Prefixed_Reference (N);
+               if Nkind (Parent (N)) = N_Explicit_Dereference
+                 and then Has_Non_Standard_Rep (Designated_Type (Etype (N)))
+               then
+                  return False;
+               else
+                  return Safe_Prefixed_Reference (N);
+               end if;
 
             --  A range is side effect free if the bounds are side effect free
 
@@ -4419,8 +4468,8 @@ package body Exp_Util is
                return Side_Effect_Free (Discrete_Range (N))
                  and then Safe_Prefixed_Reference (N);
 
-            --  A type conversion is side effect free if the expression
-            --  to be converted is side effect free.
+            --  A type conversion is side effect free if the expression to be
+            --  converted is side effect free.
 
             when N_Type_Conversion =>
                return Side_Effect_Free (Expression (N));
@@ -4496,8 +4545,7 @@ package body Exp_Util is
             return False;
 
          elsif Is_Entity_Name (N) then
-            return
-              Ekind (Entity (N)) = E_In_Parameter;
+            return Ekind (Entity (N)) = E_In_Parameter;
 
          elsif Nkind (N) = N_Indexed_Component
            or else Nkind (N) = N_Selected_Component
@@ -4523,19 +4571,19 @@ package body Exp_Util is
 
       Scope_Suppress := (others => True);
 
-      --  If it is a scalar type and we need to capture the value, just
-      --  make a copy.  Likewise for a function call.  And if we have a
-      --  volatile variable and Nam_Req is not set (see comments above
-      --  for Side_Effect_Free).
+      --  If it is a scalar type and we need to capture the value, just make
+      --  a copy. Likewise for a function or operator call. And if we have a
+      --  volatile variable and Nam_Req is not set (see comments above for
+      --  Side_Effect_Free).
 
       if Is_Elementary_Type (Exp_Type)
         and then (Variable_Ref
                    or else Nkind (Exp) = N_Function_Call
+                   or else Nkind (Exp) in N_Op
                    or else (not Name_Req
                              and then Is_Entity_Name (Exp)
                              and then Treat_As_Volatile (Entity (Exp))))
       then
-
          Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
          Set_Etype (Def_Id, Exp_Type);
          Res := New_Reference_To (Def_Id, Loc);
index ccf6740..cd34407 100644 (file)
@@ -438,6 +438,10 @@ package Exp_Util is
    --  False otherwise. True for an empty list. It is an error to call this
    --  routine with No_List as the argument.
 
+   function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean;
+   --  Return True if Typ is a library level tagged type. Currently we use
+   --  this information to build statically allocated dispatch tables.
+
    function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean;
    --  Ada 2005 (AI-251): Determines if E is a predefined primitive operation
 
@@ -628,7 +632,7 @@ package Exp_Util is
    --  control to escape doing the undefer call.
 
 private
-   pragma Inline (Force_Evaluation);
    pragma Inline (Duplicate_Subexpr);
-
+   pragma Inline (Force_Evaluation);
+   pragma Inline (Is_Library_Level_Tagged_Type);
 end Exp_Util;
index 6e448b1..44cb73b 100644 (file)
@@ -369,7 +369,7 @@ package body Freeze is
                   and then Etype (Old_S) /= Standard_Void_Type)
       then
          Call_Node :=
-           Make_Return_Statement (Loc,
+           Make_Simple_Return_Statement (Loc,
               Expression =>
                 Make_Function_Call (Loc,
                   Name => Call_Name,
@@ -377,12 +377,12 @@ package body Freeze is
 
       elsif Ekind (Old_S) = E_Enumeration_Literal then
          Call_Node :=
-           Make_Return_Statement (Loc,
+           Make_Simple_Return_Statement (Loc,
               Expression => New_Occurrence_Of (Old_S, Loc));
 
       elsif Nkind (Nam) = N_Character_Literal then
          Call_Node :=
-           Make_Return_Statement (Loc,
+           Make_Simple_Return_Statement (Loc,
              Expression => Call_Name);
 
       else
@@ -2235,7 +2235,9 @@ package body Freeze is
                            Set_Is_Frozen (E, False);
                            return No_List;
 
-                        elsif not After_Last_Declaration then
+                        elsif not After_Last_Declaration
+                          and then not Freezing_Library_Level_Tagged_Type
+                        then
                            Error_Msg_Node_1 := F_Type;
                            Error_Msg
                              ("type& must be fully defined before this point",
@@ -2465,7 +2467,7 @@ package body Freeze is
                then
                   Error_Msg_N
                     ("stand alone atomic constant must be " &
-                     "imported ('R'M 'C.6(13))", E);
+                     "imported ('R'M C.6(13))", E);
 
                elsif Has_Rep_Pragma (E, Name_Volatile)
                        or else
@@ -2473,7 +2475,7 @@ package body Freeze is
                then
                   Error_Msg_N
                     ("stand alone volatile constant must be " &
-                     "imported ('R'M 'C.6(13))", E);
+                     "imported (RM C.6(13))", E);
                end if;
             end if;
 
@@ -2530,6 +2532,100 @@ package body Freeze is
 
          if E /= Base_Type (E) then
 
+            --  Before we do anything else, a specialized test for the case of
+            --  a size given for an array where the array needs to be packed,
+            --  but was not so the size cannot be honored. This would of course
+            --  be caught by the backend, and indeed we don't catch all cases.
+            --  The point is that we can give a better error message in those
+            --  cases that we do catch with the circuitry here. Also if pragma
+            --  Implicit_Packing is set, this is where the packing occurs.
+
+            --  The reason we do this so early is that the processing in the
+            --  automatic packing case affects the layout of the base type, so
+            --  it must be done before we freeze the base type.
+
+            if Is_Array_Type (E) then
+               declare
+                  Lo, Hi : Node_Id;
+                  Ctyp   : constant Entity_Id := Component_Type (E);
+
+               begin
+                  --  Check enabling conditions. These are straightforward
+                  --  except for the test for a limited composite type. This
+                  --  eliminates the rare case of a array of limited components
+                  --  where there are issues of whether or not we can go ahead
+                  --  and pack the array (since we can't freely pack and unpack
+                  --  arrays if they are limited).
+
+                  --  Note that we check the root type explicitly because the
+                  --  whole point is we are doing this test before we have had
+                  --  a chance to freeze the base type (and it is that freeze
+                  --  action that causes stuff to be inherited).
+
+                  if Present (Size_Clause (E))
+                    and then Known_Static_Esize (E)
+                    and then not Is_Packed (E)
+                    and then not Has_Pragma_Pack (E)
+                    and then Number_Dimensions (E) = 1
+                    and then not Has_Component_Size_Clause (E)
+                    and then Known_Static_Esize (Ctyp)
+                    and then not Is_Limited_Composite (E)
+                    and then not Is_Packed (Root_Type (E))
+                    and then not Has_Component_Size_Clause (Root_Type (E))
+                  then
+                     Get_Index_Bounds (First_Index (E), Lo, Hi);
+
+                     if Compile_Time_Known_Value (Lo)
+                       and then Compile_Time_Known_Value (Hi)
+                       and then Known_Static_RM_Size (Ctyp)
+                       and then RM_Size (Ctyp) < 64
+                     then
+                        declare
+                           Lov  : constant Uint      := Expr_Value (Lo);
+                           Hiv  : constant Uint      := Expr_Value (Hi);
+                           Len  : constant Uint      := UI_Max
+                                                         (Uint_0,
+                                                          Hiv - Lov + 1);
+                           Rsiz : constant Uint      := RM_Size (Ctyp);
+                           SZ   : constant Node_Id   := Size_Clause (E);
+                           Btyp : constant Entity_Id := Base_Type (E);
+
+                        --  What we are looking for here is the situation where
+                        --  the RM_Size given would be exactly right if there
+                        --  was a pragma Pack (resulting in the component size
+                        --  being the same as the RM_Size). Furthermore, the
+                        --  component type size must be an odd size (not a
+                        --  multiple of storage unit)
+
+                        begin
+                           if RM_Size (E) = Len * Rsiz
+                             and then Rsiz mod System_Storage_Unit /= 0
+                           then
+                              --  For implicit packing mode, just set the
+                              --  component size silently
+
+                              if Implicit_Packing then
+                                 Set_Component_Size       (Btyp, Rsiz);
+                                 Set_Is_Bit_Packed_Array  (Btyp);
+                                 Set_Is_Packed            (Btyp);
+                                 Set_Has_Non_Standard_Rep (Btyp);
+
+                                 --  Otherwise give an error message
+
+                              else
+                                 Error_Msg_NE
+                                   ("size given for& too small", SZ, E);
+                                 Error_Msg_N
+                                   ("\use explicit pragma Pack "
+                                    & "or use pragma Implicit_Packing", SZ);
+                              end if;
+                           end if;
+                        end;
+                     end if;
+                  end if;
+               end;
+            end if;
+
             --  If ancestor subtype present, freeze that first.
             --  Note that this will also get the base type frozen.
 
@@ -2558,7 +2654,6 @@ package body Freeze is
          if Is_Array_Type (E) then
             declare
                Ctyp : constant Entity_Id := Component_Type (E);
-               Pnod : Node_Id;
 
                Non_Standard_Enum : Boolean := False;
                --  Set true if any of the index types is an enumeration type
@@ -2644,80 +2739,110 @@ package body Freeze is
                         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.
 
-                        --  We set the component size for all cases 1-64
+                           --  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)
+                           then
+                              Error_Msg_Sloc := Sloc (Comp_Size_C);
+                              Error_Msg_NE
+                                ("?pragma Pack for& ignored!",
+                                 Pack_Pragma, Ent);
+                              Error_Msg_N
+                                ("\?explicit component size given#!",
+                                 Pack_Pragma);
+                           end if;
 
-                        Set_Component_Size (Base_Type (E), Csiz);
+                           --  Set component size if not already set by a
+                           --  component size clause.
 
-                        --  Check for base type of 8, 16, 32 bits, where the
-                        --  subtype has a length one less than the base type
-                        --  and is unsigned (e.g. Natural subtype of Integer).
+                           if not Present (Comp_Size_C) then
+                              Set_Component_Size (E, Csiz);
+                           end if;
 
-                        --  In such cases, if a component size was not set
-                        --  explicitly, then generate a warning.
+                           --  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).
 
-                        if Has_Pragma_Pack (E)
-                          and then not Has_Component_Size_Clause (E)
-                          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;
-                           Pnod :=
-                             Get_Rep_Pragma (First_Subtype (E), Name_Pack);
+                           --  In such cases, if a component size was not set
+                           --  explicitly, then generate a warning.
 
-                           if Present (Pnod) then
-                              Error_Msg_N
-                                ("pragma Pack causes component size to be ^?",
-                                 Pnod);
-                              Error_Msg_N
-                                ("\use Component_Size to set desired value",
-                                 Pnod);
+                           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;
-                        end if;
 
-                        --  Actual packing is not needed for 8, 16, 32, 64.
-                        --  Also not needed for 24 if alignment is 1.
+                           --  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.
+                           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.
+                              --  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.
+                              --  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_Packed (Base_Type (E), False);
 
-                        --  In all other cases, packing is indeed needed
+                              --  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));
-                        end if;
+                           else
+                              Set_Has_Non_Standard_Rep (Base_Type (E));
+                              Set_Is_Bit_Packed_Array  (Base_Type (E));
+                              Set_Is_Packed            (Base_Type (E));
+                           end if;
+                        end;
                      end if;
                   end;
 
@@ -2755,63 +2880,6 @@ package body Freeze is
                   end;
                end if;
 
-               --  Check one common case of a size given where the array
-               --  needs to be packed, but was not so the size cannot be
-               --  honored. This would of course be caught by the backend,
-               --  and indeed we don't catch all cases. The point is that
-               --  we can give a better error message in those cases that
-               --  we do catch with the circuitry here.
-
-               declare
-                  Lo, Hi : Node_Id;
-                  Ctyp   : constant Entity_Id := Component_Type (E);
-
-               begin
-                  if Present (Size_Clause (E))
-                    and then Known_Static_Esize (E)
-                    and then not Is_Bit_Packed_Array (E)
-                    and then not Has_Pragma_Pack (E)
-                    and then Number_Dimensions (E) = 1
-                    and then not Has_Component_Size_Clause (E)
-                    and then Known_Static_Esize (Ctyp)
-                  then
-                     Get_Index_Bounds (First_Index (E), Lo, Hi);
-
-                     if Compile_Time_Known_Value (Lo)
-                       and then Compile_Time_Known_Value (Hi)
-                       and then Known_Static_RM_Size (Ctyp)
-                       and then RM_Size (Ctyp) < 64
-                     then
-                        declare
-                           Lov  : constant Uint := Expr_Value (Lo);
-                           Hiv  : constant Uint := Expr_Value (Hi);
-                           Len  : constant Uint :=
-                                    UI_Max (Uint_0, Hiv - Lov + 1);
-                           Rsiz : constant Uint := RM_Size (Ctyp);
-
-                        --  What we are looking for here is the situation where
-                        --  the RM_Size given would be exactly right if there
-                        --  was a pragma Pack (resulting in the component size
-                        --  being the same as the RM_Size). Furthermore, the
-                        --  component type size must be an odd size (not a
-                        --  multiple of storage unit)
-
-                        begin
-                           if RM_Size (E) = Len * Rsiz
-                             and then Rsiz mod System_Storage_Unit /= 0
-                           then
-                              Error_Msg_NE
-                                ("size given for& too small",
-                                   Size_Clause (E), E);
-                              Error_Msg_N
-                                ("\explicit pragma Pack is required",
-                                   Size_Clause (E));
-                           end if;
-                        end;
-                     end if;
-                  end if;
-               end;
-
                --  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).
@@ -2871,6 +2939,16 @@ package body Freeze is
          elsif Is_Class_Wide_Type (E) then
             Freeze_And_Append (Root_Type (E), Loc, Result);
 
+            --  If the base type of the class-wide type is still incomplete,
+            --  the class-wide remains unfrozen as well. This is legal when
+            --  E is the formal of a primitive operation of some other type
+            --  which is being frozen.
+
+            if not Is_Frozen (Root_Type (E)) then
+               Set_Is_Frozen (E, False);
+               return Result;
+            end if;
+
             --  If the Class_Wide_Type is an Itype (when type is the anonymous
             --  parent of a derived type) and it is a library-level entity,
             --  generate an itype reference for it. Otherwise, its first
@@ -2967,9 +3045,34 @@ package body Freeze is
          elsif Is_Incomplete_Or_Private_Type (E)
            and then not Is_Generic_Type (E)
          then
+            --  The construction of the dispatch table associated with library
+            --  level tagged types forces freezing of all the primitives of the
+            --  type, which may cause premature freezing of the partial view.
+            --  For example:
+
+            --     package Pkg is
+            --        type T is tagged private;
+            --        type DT is new T with private;
+            --        procedure Prim (X : in out T; Y : in out DT'class);
+            --     private
+            --        type T is tagged null record;
+            --        Obj : T;
+            --        type DT is new T with null record;
+            --     end;
+
+            --  In this case the type will be frozen later by the usual
+            --  mechanism: an object declaration, an instantiation, or the
+            --  end of a declarative part.
+
+            if Is_Library_Level_Tagged_Type (E)
+              and then not Present (Full_View (E))
+            then
+               Set_Is_Frozen (E, False);
+               return Result;
+
             --  Case of full view present
 
-            if Present (Full_View (E)) then
+            elsif Present (Full_View (E)) then
 
                --  If full view has already been frozen, then no further
                --  processing is required
@@ -4783,8 +4886,9 @@ package body Freeze is
             return True;
          end;
 
-      else return not Is_Private_Type (T)
-        or else Present (Full_View (Base_Type (T)));
+      else
+         return not Is_Private_Type (T)
+           or else Present (Full_View (Base_Type (T)));
       end if;
    end Is_Fully_Defined;
 
@@ -4818,7 +4922,6 @@ package body Freeze is
       end if;
 
       Formal := First_Formal (E);
-
       while Present (Formal) loop
          if Present (Default_Value (Formal)) then
 
@@ -4841,7 +4944,7 @@ package body Freeze is
                         and then not Vax_Float (Etype (Dcopy)))
               or else Nkind (Dcopy) = N_Character_Literal
               or else Nkind (Dcopy) = N_String_Literal
-              or else Nkind (Dcopy) = N_Null
+              or else Known_Null (Dcopy)
               or else (Nkind (Dcopy) = N_Attribute_Reference
                         and then
                        Attribute_Name (Dcopy) = Name_Null_Parameter)
@@ -5180,7 +5283,7 @@ package body Freeze is
 
          Error_Msg_N
            ("\use pragma Import for & to " &
-            "suppress initialization ('R'M B.1(24))?",
+            "suppress initialization (RM B.1(24))?",
             Nam);
       end if;
    end Warn_Overlay;
index 125a706..13afe37 100644 (file)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
@@ -121,6 +121,12 @@ package Freeze is
    --  base types, where the freeze node is preallocated at the point of
    --  declaration, so that the First_Subtype_Link field can be set.
 
+   Freezing_Library_Level_Tagged_Type : Boolean := False;
+   --  Flag used to indicate that we are freezing the primitives of a library
+   --  level tagged types. Used to disable checks on premature freezing.
+   --  More documentation needed??? why is this flag needed? what are these
+   --  checks? why do they need disabling in some cases?
+
    -----------------
    -- Subprograms --
    -----------------