[multiple changes]
authorArnaud Charlet <charlet@gcc.gnu.org>
Tue, 2 Aug 2011 13:16:09 +0000 (15:16 +0200)
committerArnaud Charlet <charlet@gcc.gnu.org>
Tue, 2 Aug 2011 13:16:09 +0000 (15:16 +0200)
2011-08-02  Robert Dewar  <dewar@adacore.com>

* sem_attr.adb: Minor reformatting.

2011-08-02  Ed Falis  <falis@adacore.com>

* init.c: Revert previous change.

2011-08-02  Robert Dewar  <dewar@adacore.com>

* einfo.adb (Has_Default_Aspect): Replaces Has_Default_Value
(Has_Default_Component_Value): Removed
* einfo.ads Comment updates
(Has_Default_Aspect): Replaces Has_Default_Value
(Has_Default_Component_Value): Removed
* exp_ch13.adb
(Expand_N_Freeze_Entity): Handle Default[_Component]_Value aspects
* exp_ch3.adb
(Build_Array_Init_Proc): Handle Default_[Component_]Value aspects
(Get_Simple_Init_Val): Handle Default_Value aspect
(Needs_Simple_Initialization): Handle Default_Value aspect
* exp_ch3.ads: Needs_Simple_Initialization
* freeze.adb (Freeze_Entity): Handle Default_[Component_]Value aspect
* par-prag.adb (Pragma_Default[_Component]Value) Removed
* sem_ch13.adb
(Analyze_Aspect_Specifications): Fix Default[_Component]_Value aspects
* sem_prag.adb (Pragma_Default[_Component]Value) Removed
* snames.ads-tmpl (Pragma_Default[_Component]Value) Removed

2011-08-02  Ed Schonberg  <schonberg@adacore.com>

* sem_ch5.adb (Analyze_Iterator_Specification): use base type to locate
package containing iteration primitives.
exp_ch5.adb (Expand_Iterator_Loop): ditto.

From-SVN: r177147

15 files changed:
gcc/ada/ChangeLog
gcc/ada/einfo.adb
gcc/ada/einfo.ads
gcc/ada/exp_ch13.adb
gcc/ada/exp_ch3.adb
gcc/ada/exp_ch3.ads
gcc/ada/exp_ch5.adb
gcc/ada/freeze.adb
gcc/ada/init.c
gcc/ada/par-prag.adb
gcc/ada/sem_attr.adb
gcc/ada/sem_ch13.adb
gcc/ada/sem_ch5.adb
gcc/ada/sem_prag.adb
gcc/ada/snames.ads-tmpl

index 9b6d9734b86835a990738cfa0e9598b1a8d5a409..09f5a9552c2a011506449615570b9a59715e0315 100644 (file)
@@ -1,3 +1,34 @@
+2011-08-02  Robert Dewar  <dewar@adacore.com>
+
+       * sem_attr.adb: Minor reformatting.
+
+2011-08-02  Robert Dewar  <dewar@adacore.com>
+
+       * einfo.adb (Has_Default_Aspect): Replaces Has_Default_Value
+       (Has_Default_Component_Value): Removed
+       * einfo.ads Comment updates
+       (Has_Default_Aspect): Replaces Has_Default_Value
+       (Has_Default_Component_Value): Removed
+       * exp_ch13.adb
+       (Expand_N_Freeze_Entity): Handle Default[_Component]_Value aspects
+       * exp_ch3.adb
+       (Build_Array_Init_Proc): Handle Default_[Component_]Value aspects
+       (Get_Simple_Init_Val): Handle Default_Value aspect
+       (Needs_Simple_Initialization): Handle Default_Value aspect
+       * exp_ch3.ads: Needs_Simple_Initialization
+       * freeze.adb (Freeze_Entity): Handle Default_[Component_]Value aspect
+       * par-prag.adb (Pragma_Default[_Component]Value) Removed
+       * sem_ch13.adb
+       (Analyze_Aspect_Specifications): Fix Default[_Component]_Value aspects
+       * sem_prag.adb (Pragma_Default[_Component]Value) Removed
+       * snames.ads-tmpl (Pragma_Default[_Component]Value) Removed
+
+2011-08-02  Ed Schonberg  <schonberg@adacore.com>
+
+       * sem_ch5.adb (Analyze_Iterator_Specification): use base type to locate
+       package containing iteration primitives.
+       exp_ch5.adb (Expand_Iterator_Loop): ditto.
+
 2011-08-02  Ed Schonberg  <schonberg@adacore.com>
 
        * sem_ch5.adb (Analyze_Iteration_Scheme): For an Ada2012 iterator with
        * s-stusta.adb (Print): Make sure Pos is always initialized to a
        suitable value.
 
-2011-08-02  Ed Falis  <falis@adacore.com>
-
-       * init.c: Fix conditional compilation so that the fp initialization is
-       peformed for the MILS VxWorks Guest OS.
-
 2011-08-02  Geert Bosch  <bosch@adacore.com>
 
        * a-calfor.adb (Image): Simplify, removing unnecessary uses of 'Image.
index c050776911b39e6db604a27ff90a87123aa8cf44..fedf63b70dae39da87a833e20b00befae070faf3 100644 (file)
@@ -284,7 +284,7 @@ package body Einfo is
    --    Referenced_As_LHS               Flag36
    --    Is_Known_Non_Null               Flag37
    --    Can_Never_Be_Null               Flag38
-   --    Has_Default_Value               Flag39
+   --    Has_Default_Aspect              Flag39
    --    Body_Needed_For_SAL             Flag40
 
    --    Treat_As_Volatile               Flag41
@@ -408,7 +408,6 @@ package body Einfo is
    --    Is_Compilation_Unit             Flag149
    --    Has_Pragma_Elaborate_Body       Flag150
 
-   --    Has_Default_Component_Value     Flag151
    --    Entry_Accepted                  Flag152
    --    Is_Obsolescent                  Flag153
    --    Has_Per_Object_Constraint       Flag154
@@ -518,6 +517,7 @@ package body Einfo is
    --    Is_Safe_To_Reevaluate           Flag249
    --    Has_Predicates                  Flag250
 
+   --    (unused)                        Flag151
    --    (unused)                        Flag251
    --    (unused)                        Flag252
    --    (unused)                        Flag253
@@ -1227,17 +1227,10 @@ package body Einfo is
       return Flag119 (Id);
    end Has_Convention_Pragma;
 
-   function Has_Default_Component_Value (Id : E) return B is
+   function Has_Default_Aspect (Id : E) return B is
    begin
-      pragma Assert (Is_Array_Type (Id));
-      return Flag151 (Base_Type (Id));
-   end Has_Default_Component_Value;
-
-   function Has_Default_Value (Id : E) return B is
-   begin
-      pragma Assert (Is_Scalar_Type (Id));
       return Flag39 (Base_Type (Id));
-   end Has_Default_Value;
+   end Has_Default_Aspect;
 
    function Has_Delayed_Aspects (Id : E) return B is
    begin
@@ -3687,17 +3680,13 @@ package body Einfo is
       Set_Flag119 (Id, V);
    end Set_Has_Convention_Pragma;
 
-   procedure Set_Has_Default_Component_Value (Id : E; V : B := True) is
+   procedure Set_Has_Default_Aspect (Id : E; V : B := True) is
    begin
-      pragma Assert (Is_Array_Type (Id) and then Is_Base_Type (Id));
-      Set_Flag151 (Id, V);
-   end Set_Has_Default_Component_Value;
-
-   procedure Set_Has_Default_Value (Id : E; V : B := True) is
-   begin
-      pragma Assert (Is_Scalar_Type (Id) and then Is_Base_Type (Id));
+      pragma Assert
+        ((Is_Scalar_Type (Id) or else Is_Array_Type (Id))
+           and then Is_Base_Type (Id));
       Set_Flag39 (Id, V);
-   end Set_Has_Default_Value;
+   end Set_Has_Default_Aspect;
 
    procedure Set_Has_Delayed_Aspects (Id : E; V : B := True) is
    begin
@@ -7379,8 +7368,7 @@ package body Einfo is
       W ("Has_Controlled_Component",        Flag43  (Id));
       W ("Has_Controlling_Result",          Flag98  (Id));
       W ("Has_Convention_Pragma",           Flag119 (Id));
-      W ("Has_Default_Component_Value",     Flag151 (Id));
-      W ("Has_Default_Value",               Flag39  (Id));
+      W ("Has_Default_Aspect",              Flag39  (Id));
       W ("Has_Delayed_Aspects",             Flag200 (Id));
       W ("Has_Delayed_Freeze",              Flag18  (Id));
       W ("Has_Discriminants",               Flag5   (Id));
index 45dd3b4778f4d626caf6832d3f946901f7f56e49..b319cf4b578d477e4c7ddda0b723a958de9f500d 100644 (file)
@@ -462,15 +462,15 @@ package Einfo is
 --       the value of the entry barrier.
 
 --    Base_Type (synthesized)
---       Applies to all type entities. Returns the base type of a type or
---       subtype. The base type of a type is the type itself. The base type
---       of a subtype is the type that it constrains (which is always a type
---       entity, not some other subtype). Note that in the case of a subtype
---       of a private type, it is possible for the base type attribute to
---       return a private type, even if the subtype to which it applies is
---       non-private. See also Implementation_Base_Type. Note: it is allowed
---       to apply Base_Type to other than a type, in which case it simply
---       returns the entity unchanged.
+--       Applies to all type and subtype entities. Returns the base type of a
+--       type or subtype. The base type of a type is the type itself. The base
+--       type of a subtype is the type that it constrains (which is always
+--       a type entity, not some other subtype). Note that in the case of a
+--       subtype of a private type, it is possible for the base type attribute
+--       to return a private type, even if the subtype to which it applies is
+--       non-private. See also Implementation_Base_Type. Note: it is allowed to
+--       apply Base_Type to other than a type, in which case it simply returns
+--       the entity unchanged.
 
 --    Block_Node (Node11)
 --       Present in block entities. Points to the identifier in the
@@ -1407,10 +1407,10 @@ package Einfo is
 --       function of a tagged type which can dispatch on result.
 
 --    Has_Controlled_Component (Flag43) [base type only]
---       Present in all entities. Set only for composite type entities which
---       contain a component that either is a controlled type, or itself
---       contains controlled component (i.e. either Has_Controlled_Component
---       or Is_Controlled is set for at least one component).
+--       Present in all type and subtype entities. Set only for composite type
+--       entities which contain a component that either is a controlled type,
+--       or itself contains controlled component (i.e. either Is_Controlled or
+--       Has_Controlled_Component is set for at least one component).
 
 --    Has_Convention_Pragma (Flag119)
 --       Present in all entities. Set true for an entity for which a valid
@@ -1428,17 +1428,11 @@ package Einfo is
 --       node must be generated for the entity at its freezing point. See
 --       separate section ("Delayed Freezing and Elaboration") for details.
 
---    Has_Default_Component_Value (Flag151) [root type only]
---       Present in array types. Set on a base type to indicate that the base
---       type and all its subtypes have a Default_Component_Value aspect. If
---       this flag is True, then there will be a pragma Default_Component_Value
---       chained to the Rep_Item list for the base type.
-
---    Has_Default_Value (Flag39) [base type only]
---       Present in scalar types. Set on a base type to indicate that the base
---       type and all its subtypes have a Default_Value aspect. If this flag is
---       True, then there will always be a pragma Default_Value chained to the
---       Rep_Item list for the base type.
+--    Has_Default_Aspect (Flag39) [base type only]
+--       Present in entities for types and subtypes, set for scalar types with
+--       a Default_Value aspect and array types with a Default_Component_Value
+--       apsect. If this flag is set, then a corresponding aspect specification
+--       node will be present on the rep item chain for the entity.
 
 --    Has_Discriminants (Flag5)
 --       Present in all types and subtypes. For types that are allowed to have
@@ -1650,9 +1644,9 @@ package Einfo is
 --       case since we allow multiple occurrences of this pragma anyway.
 
 --    Has_Pragma_Pack (Flag121) [implementation base type only]
---       Present in all entities. If set, indicates that a valid pragma Pack
---       was given for the type. Note that this flag is not inherited by
---       derived type. See also the Is_Packed flag.
+--       Present in array and record type entities. If set, indicates that a
+--       valid pragma Pack was given for the type. Note that this flag is not
+--       inherited by derived type. See also the Is_Packed flag.
 
 --    Has_Pragma_Pure (Flag203)
 --       Present in all entities. If set, indicates that a valid pragma Pure
@@ -4690,7 +4684,6 @@ package Einfo is
    --    Checks_May_Be_Suppressed            (Flag31)
    --    Debug_Info_Off                      (Flag166)
    --    Has_Anon_Block_Suffix               (Flag201)
-   --    Has_Controlled_Component            (Flag43)   (base type only)
    --    Has_Convention_Pragma               (Flag119)
    --    Has_Delayed_Aspects                 (Flag200)
    --    Has_Delayed_Freeze                  (Flag18)
@@ -4701,7 +4694,6 @@ package Einfo is
    --    Has_Pragma_Elaborate_Body           (Flag150)
    --    Has_Pragma_Inline                   (Flag157)
    --    Has_Pragma_Inline_Always            (Flag230)
-   --    Has_Pragma_Pack                     (Flag121)  (base type only)
    --    Has_Pragma_Pure                     (Flag203)
    --    Has_Pragma_Pure_Function            (Flag179)
    --    Has_Pragma_Thread_Local_Storage     (Flag169)
@@ -4813,6 +4805,8 @@ package Einfo is
    --    Has_Completion_In_Body              (Flag71)
    --    Has_Complex_Representation          (Flag140)  (base type only)
    --    Has_Constrained_Partial_View        (Flag187)
+   --    Has_Controlled_Component            (Flag43)   (base type only)
+   --    Has_Default_Aspect                  (Flag39)   (base type only)
    --    Has_Discriminants                   (Flag5)
    --    Has_Inheritable_Invariants          (Flag248)
    --    Has_Invariants                      (Flag232)
@@ -4935,7 +4929,7 @@ package Einfo is
    --    Packed_Array_Type                   (Node23)
    --    Component_Alignment                 (special)  (base type only)
    --    Has_Component_Size_Clause           (Flag68)   (base type only)
-   --    Has_Default_Component_Value         (Flag151)  (base type only)
+   --    Has_Pragma_Pack                     (Flag121)  (impl base type only)
    --    Is_Aliased                          (Flag15)
    --    Is_Constrained                      (Flag12)
    --    Next_Index                          (synth)
@@ -5035,7 +5029,6 @@ package Einfo is
    --    Scalar_Range                        (Node20)
    --    Delta_Value                         (Ureal18)
    --    Small_Value                         (Ureal21)
-   --    Has_Default_Value                   (Flag39)   (base type only)
    --    Has_Machine_Radix_Clause            (Flag83)
    --    Machine_Radix_10                    (Flag84)
    --    Aft_Value                           (synth)
@@ -5112,7 +5105,6 @@ package Einfo is
    --    Static_Predicate                    (List25)
    --    Has_Biased_Representation           (Flag139)
    --    Has_Contiguous_Rep                  (Flag181)
-   --    Has_Default_Value                   (Flag39)   (base type only)
    --    Has_Enumeration_Rep_Clause          (Flag66)
    --    Has_Pragma_Ordered                  (Flag198)  (base type only)
    --    Nonzero_Is_True                     (Flag162)  (base type only)
@@ -5140,7 +5132,6 @@ package Einfo is
    --    Digits_Value                        (Uint17)
    --    Float_Rep                           (Uint10)   (Float_Rep_Kind)
    --    Scalar_Range                        (Node20)
-   --    Has_Default_Value                   (Flag39)   (base type only)
    --    Machine_Emax_Value                  (synth)
    --    Machine_Emin_Value                  (synth)
    --    Machine_Mantissa_Value              (synth)
@@ -5315,7 +5306,6 @@ package Einfo is
    --    Static_Predicate                    (List25)
    --    Non_Binary_Modulus                  (Flag58)   (base type only)
    --    Has_Biased_Representation           (Flag139)
-   --    Has_Default_Value                   (Flag39)   (base type only)
    --    Type_Low_Bound                      (synth)
    --    Type_High_Bound                     (synth)
    --    (plus type attributes)
@@ -5346,7 +5336,6 @@ package Einfo is
    --    Delta_Value                         (Ureal18)
    --    Scalar_Range                        (Node20)
    --    Small_Value                         (Ureal21)
-   --    Has_Default_Value                   (Flag39)   (base type only)
    --    Has_Small_Clause                    (Flag67)
    --    Aft_Value                           (synth)
    --    Type_Low_Bound                      (synth)
@@ -5535,6 +5524,7 @@ package Einfo is
    --    C_Pass_By_Copy                      (Flag125)  (base type only)
    --    Has_Dispatch_Table                  (Flag220)  (base tagged type only)
    --    Has_External_Tag_Rep_Clause         (Flag110)
+   --    Has_Pragma_Pack                     (Flag121)  (impl base type only)
    --    Has_Record_Rep_Clause               (Flag65)   (base type only)
    --    Has_Static_Discriminants            (Flag211)  (subtype only)
    --    Is_Class_Wide_Equivalent_Type       (Flag35)
@@ -5583,7 +5573,6 @@ package Einfo is
    --    Scalar_Range                        (Node20)
    --    Static_Predicate                    (List25)
    --    Has_Biased_Representation           (Flag139)
-   --    Has_Default_Value                   (Flag39)   (base type only)
    --    Type_Low_Bound                      (synth)
    --    Type_High_Bound                     (synth)
    --    (plus type attributes)
@@ -6034,8 +6023,7 @@ package Einfo is
    function Has_Controlled_Component            (Id : E) return B;
    function Has_Controlling_Result              (Id : E) return B;
    function Has_Convention_Pragma               (Id : E) return B;
-   function Has_Default_Component_Value         (Id : E) return B;
-   function Has_Default_Value                   (Id : E) return B;
+   function Has_Default_Aspect                  (Id : E) return B;
    function Has_Delayed_Aspects                 (Id : E) return B;
    function Has_Delayed_Freeze                  (Id : E) return B;
    function Has_Discriminants                   (Id : E) return B;
@@ -6618,8 +6606,7 @@ package Einfo is
    procedure Set_Has_Controlled_Component        (Id : E; V : B := True);
    procedure Set_Has_Controlling_Result          (Id : E; V : B := True);
    procedure Set_Has_Convention_Pragma           (Id : E; V : B := True);
-   procedure Set_Has_Default_Component_Value     (Id : E; V : B := True);
-   procedure Set_Has_Default_Value               (Id : E; V : B := True);
+   procedure Set_Has_Default_Aspect              (Id : E; V : B := True);
    procedure Set_Has_Delayed_Aspects             (Id : E; V : B := True);
    procedure Set_Has_Delayed_Freeze              (Id : E; V : B := True);
    procedure Set_Has_Discriminants               (Id : E; V : B := True);
@@ -7311,8 +7298,7 @@ package Einfo is
    pragma Inline (Has_Controlled_Component);
    pragma Inline (Has_Controlling_Result);
    pragma Inline (Has_Convention_Pragma);
-   pragma Inline (Has_Default_Component_Value);
-   pragma Inline (Has_Default_Value);
+   pragma Inline (Has_Default_Aspect);
    pragma Inline (Has_Delayed_Aspects);
    pragma Inline (Has_Delayed_Freeze);
    pragma Inline (Has_Discriminants);
@@ -7751,8 +7737,7 @@ package Einfo is
    pragma Inline (Set_Has_Controlled_Component);
    pragma Inline (Set_Has_Controlling_Result);
    pragma Inline (Set_Has_Convention_Pragma);
-   pragma Inline (Set_Has_Default_Component_Value);
-   pragma Inline (Set_Has_Default_Value);
+   pragma Inline (Set_Has_Default_Aspect);
    pragma Inline (Set_Has_Delayed_Aspects);
    pragma Inline (Set_Has_Delayed_Freeze);
    pragma Inline (Set_Has_Discriminants);
index 47e39c4f38bf66f9b7a5c7ee47db3ddd5739a710..39b32cec46dfcc8aaf0a56f8bb9493cf0de1263b 100644 (file)
@@ -240,8 +240,14 @@ package body Exp_Ch13 is
                  and then Entity (Ritem) = E
                then
                   Aitem := Aspect_Rep_Item (Ritem);
-                  pragma Assert (Is_Delayed_Aspect (Aitem));
-                  Insert_Before (N, Aitem);
+
+                  --  Skip this for aspects (e.g. Current_Value) for which
+                  --  there is no corresponding pragma or attribute.
+
+                  if Present (Aitem) then
+                     pragma Assert (Is_Delayed_Aspect (Aitem));
+                     Insert_Before (N, Aitem);
+                  end if;
                end if;
 
                Next_Rep_Item (Ritem);
index 7eb6c99f2728b0d4c51b527360c6fc1e3d202e79..99a14fdfffc0cf97b705980a4face7d2b7384435 100644 (file)
@@ -583,11 +583,23 @@ package body Exp_Ch3 is
              Prefix      => Make_Identifier (Loc, Name_uInit),
              Expressions => Index_List);
 
-         if Needs_Simple_Initialization (Comp_Type) then
+         if Has_Default_Aspect (A_Type) then
             Set_Assignment_OK (Comp);
             return New_List (
               Make_Assignment_Statement (Loc,
-                Name => Comp,
+                Name       => Comp,
+                Expression =>
+                  Convert_To (Comp_Type,
+                    Expression
+                      (Get_Rep_Item_For_Entity
+                        (First_Subtype (A_Type),
+                         Name_Default_Component_Value)))));
+
+         elsif Needs_Simple_Initialization (Comp_Type) then
+            Set_Assignment_OK (Comp);
+            return New_List (
+              Make_Assignment_Statement (Loc,
+                Name       => Comp,
                 Expression =>
                   Get_Simple_Init_Val
                     (Comp_Type, Nod, Component_Size (A_Type))));
@@ -617,6 +629,7 @@ package body Exp_Ch3 is
          if not Has_Non_Null_Base_Init_Proc (Comp_Type)
            and then not Needs_Simple_Initialization (Comp_Type)
            and then not Has_Task (Comp_Type)
+           and then not Has_Default_Aspect (A_Type)
          then
             return New_List (Make_Null_Statement (Loc));
 
@@ -678,6 +691,7 @@ package body Exp_Ch3 is
       --    2. The component type needs simple initialization
       --    3. Tasks are present
       --    4. The type is marked as a public entity
+      --    5. The array type has a Default_Component_Value aspect
 
       --  The reason for the public entity test is to deal properly with the
       --  Initialize_Scalars pragma. This pragma can be set in the client and
@@ -695,7 +709,8 @@ package body Exp_Ch3 is
 
       Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type)
                             or else Needs_Simple_Initialization (Comp_Type)
-                            or else Has_Task (Comp_Type);
+                            or else Has_Task (Comp_Type)
+                            or else Has_Default_Aspect (A_Type);
 
       if Has_Default_Init
         or else (not Restriction_Active (No_Initialize_Scalars)
@@ -777,7 +792,7 @@ package body Exp_Ch3 is
             Set_Is_Null_Init_Proc (Proc_Id);
 
          else
-            --  Try to build a static aggregate to initialize statically
+            --  Try to build a static aggregate to statically initialize
             --  objects of the type. This can only be done for constrained
             --  one-dimensional arrays with static bounds.
 
@@ -4831,11 +4846,11 @@ package body Exp_Ch3 is
 
                begin
                   --  If the original node of the expression was a conversion
-                  --  to this specific class-wide interface type then we
-                  --  restore the original node because we must copy the object
-                  --  before displacing the pointer to reference the secondary
-                  --  tag component. This code must be kept synchronized with
-                  --  the expansion done by routine Expand_Interface_Conversion
+                  --  to this specific class-wide interface type then restore
+                  --  the original node because we must copy the object before
+                  --  displacing the pointer to reference the secondary tag
+                  --  component. This code must be kept synchronized with the
+                  --  expansion done by routine Expand_Interface_Conversion
 
                   if not Comes_From_Source (Expr_N)
                     and then Nkind (Expr_N) = N_Explicit_Dereference
@@ -6885,8 +6900,17 @@ package body Exp_Ch3 is
 
          return Result;
 
-      --  For scalars, we must have normalize/initialize scalars case, or
-      --  if the node N is an 'Invalid_Value attribute node.
+      --  Scalars with Default_Value aspect
+
+      elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) then
+         return
+           Convert_To (T,
+             Expression
+               (Get_Rep_Item_For_Entity
+                 (First_Subtype (T), Name_Default_Value)));
+
+      --  Othersie, for scalars, we must have normalize/initialize scalars
+      --  case, or if the node N is an 'Invalid_Value attribute node.
 
       elsif Is_Scalar_Type (T) then
          pragma Assert (Init_Or_Norm_Scalars or IV_Attribute);
@@ -8522,6 +8546,11 @@ package body Exp_Ch3 is
             end if;
          end;
 
+      --  Scalar type with Default_Value aspect requires initialization
+
+      elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) then
+         return True;
+
       --  Cases needing simple initialization are access types, and, if pragma
       --  Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
       --  types.
index beb74b562bbc36f1ba312c565fa2bb9a1644d836..91431efc680b0088e254de6d774e030fdb15c18a 100644 (file)
@@ -130,14 +130,14 @@ package Exp_Ch3 is
      (T           : Entity_Id;
       Consider_IS : Boolean := True) return Boolean;
    --  Certain types need initialization even though there is no specific
-   --  initialization routine. In this category are access types (which need
-   --  initializing to null), packed array types whose implementation is a
-   --  modular type, and all scalar types if Normalize_Scalars is set, as well
-   --  as private types whose underlying type is present and meets any of these
-   --  criteria. Finally, descendants of String and Wide_String also need
-   --  initialization in Initialize/Normalize_Scalars mode. Consider_IS is
-   --  normally True. If it is False, the Initialize_Scalars is not considered
-   --  in determining whether simple initialization is needed.
+   --  initialization routine:
+   --    Access types (which need initializing to null)
+   --    All scalar types if Normalize_Scalars mode set
+   --    Descendents of standard string types if Normalize_Scalars mode set
+   --    Scalar types having a Default_Value attribute
+   --  Regarding Initialize_Scalars mode, this is ignored if Consider_IS is
+   --  set to False, but if Consider_IS is set to True, then the cases above
+   --  mentioning Normalize_Scalars also apply for Initialize_Scalars mode.
 
    function Get_Simple_Init_Val
      (T    : Entity_Id;
index f102cf9eafc3b2dea27ba5a1e4fbc64f4a415af6..854b1a0ca89b39d3b94ca584a869b01d59618ad6 100644 (file)
@@ -2860,7 +2860,7 @@ package body Exp_Ch5 is
 
          declare
             Element_Type  : constant Entity_Id := Etype (Id);
-            Pack          : constant Entity_Id := Scope (Etype (Container));
+            Pack          : constant Entity_Id := Scope (Base_Type (Typ));
             Name_Init     : Name_Id;
             Name_Step     : Name_Id;
             Cond          : Node_Id;
@@ -2915,7 +2915,11 @@ package body Exp_Ch5 is
 
             if Of_Present (I_Spec) then
 
-               --  Id : Element_Type renames Pack.Element (Cursor);
+               --  Id : Element_Type renames Container.Element (Cursor);
+
+               --  The code below only handles containers where Element is not
+               --  a primitive operation of the container. This excludes
+               --  for now the Hi-Lite formal containers.
 
                Renaming_Decl :=
                  Make_Object_Renaming_Declaration (Loc,
index f1a2b829bd0fabd4c0619410202309948f116901..06313c84e2f77b3938efea0ce62717f53c447830 100644 (file)
@@ -2423,8 +2423,14 @@ package body Freeze is
                  and then Is_Delayed_Aspect (Ritem)
                then
                   Aitem := Aspect_Rep_Item (Ritem);
-                  Set_Parent (Aitem, Ritem);
-                  Analyze (Aitem);
+
+                  --  Skip if this is an aspect with no corresponding pragma
+                  --  or attribute definition node (such as Default_Value).
+
+                  if Present (Aitem) then
+                     Set_Parent (Aitem, Ritem);
+                     Analyze (Aitem);
+                  end if;
                end if;
 
                Next_Rep_Item (Ritem);
@@ -4018,11 +4024,11 @@ package body Freeze is
             end if;
          end if;
 
-         --  Remaining process is to set/verify the representation information,
-         --  in particular the size and alignment values. This processing is
-         --  not required for generic types, since generic types do not play
-         --  any part in code generation, and so the size and alignment values
-         --  for such types are irrelevant.
+         --  Now we set/verify the representation information, in particular
+         --  the size and alignment values. This processing is not required for
+         --  generic types, since generic types do not play any part in code
+         --  generation, and so the size and alignment values for such types
+         --  are irrelevant.
 
          if Is_Generic_Type (E) then
             return Result;
@@ -4033,6 +4039,42 @@ package body Freeze is
             Layout_Type (E);
          end if;
 
+         --  If the type has a Defaut_Value/Default_Component_Value aspect,
+         --  this is where we analye the expression (after the type is frozen,
+         --  since in the case of Default_Value, we are analyzing with the
+         --  type itself, and we treat Default_Component_Value similarly for
+         --  the sake of uniformity.
+
+         if Is_First_Subtype (E) and then Has_Default_Aspect (E) then
+            declare
+               Nam    : Name_Id;
+               Aspect : Node_Id;
+               Exp    : Node_Id;
+               Typ    : Entity_Id;
+
+            begin
+               if Is_Scalar_Type (E) then
+                  Nam := Name_Default_Value;
+                  Typ := E;
+               else
+                  Nam := Name_Default_Component_Value;
+                  Typ := Component_Type (E);
+               end if;
+
+               Aspect := Get_Rep_Item_For_Entity (E, Nam);
+               Exp := Expression (Aspect);
+               Analyze_And_Resolve (Exp, Typ);
+
+               if Etype (Exp) /= Any_Type then
+                  if not Is_Static_Expression (Exp) then
+                     Error_Msg_Name_1 := Nam;
+                     Flag_Non_Static_Expr
+                       ("aspect% requires static expression", Exp);
+                  end if;
+               end if;
+            end;
+         end if;
+
          --  End of freeze processing for type entities
       end if;
 
index df0bb932ca7a588a25b5f83851d7310dca0e276d..822837c0d19cbb2a3c5824a3ed85bdfa09916688 100644 (file)
@@ -2026,7 +2026,7 @@ __gnat_init_float (void)
      to get correct Ada semantics.  Note that for AE653 vThreads, the HW
      overflow settings are an OS configuration issue.  The instructions
      below have no effect.  */
-#if defined (_ARCH_PPC) && !defined (_SOFT_FLOAT) && (!defined (VTHREADS) || defined (__VXWORKSMILS__))
+#if defined (_ARCH_PPC) && !defined (_SOFT_FLOAT) && !defined (VTHREADS)
 #if defined (__SPE__)
   {
      const unsigned long spefscr_mask = 0xfffffff3;
index d3959b74d0b00e47c16c397f317ada1419d84ecc..10237a551278e418f1dff17a4140d5f94a49aef8 100644 (file)
@@ -1136,8 +1136,6 @@ begin
            Pragma_Controlled                    |
            Pragma_Convention                    |
            Pragma_Debug_Policy                  |
-           Pragma_Default_Value                 |
-           Pragma_Default_Component_Value       |
            Pragma_Detect_Blocking               |
            Pragma_Default_Storage_Pool          |
            Pragma_Dimension                     |
index f75f36e8e9535c5f48235faf248063f0b3c9e426..08761d8fd6049f22cd413106d08ab8329d4b3f75 100644 (file)
@@ -85,61 +85,61 @@ package body Sem_Attr is
    --  that are not included in Ada 95, but still get recognized in GNAT.
 
    Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'(
-      Attribute_Address           |
-      Attribute_Aft               |
-      Attribute_Alignment         |
-      Attribute_Base              |
-      Attribute_Callable          |
-      Attribute_Constrained       |
-      Attribute_Count             |
-      Attribute_Delta             |
-      Attribute_Digits            |
-      Attribute_Emax              |
-      Attribute_Epsilon           |
-      Attribute_First             |
-      Attribute_First_Bit         |
-      Attribute_Fore              |
-      Attribute_Image             |
-      Attribute_Large             |
-      Attribute_Last              |
-      Attribute_Last_Bit          |
-      Attribute_Leading_Part      |
-      Attribute_Length            |
-      Attribute_Machine_Emax      |
-      Attribute_Machine_Emin      |
-      Attribute_Machine_Mantissa  |
-      Attribute_Machine_Overflows |
-      Attribute_Machine_Radix     |
-      Attribute_Machine_Rounds    |
-      Attribute_Mantissa          |
-      Attribute_Pos               |
-      Attribute_Position          |
-      Attribute_Pred              |
-      Attribute_Range             |
-      Attribute_Safe_Emax         |
-      Attribute_Safe_Large        |
-      Attribute_Safe_Small        |
-      Attribute_Size              |
-      Attribute_Small             |
-      Attribute_Storage_Size      |
-      Attribute_Succ              |
-      Attribute_Terminated        |
-      Attribute_Val               |
-      Attribute_Value             |
-      Attribute_Width             => True,
-      others                      => False);
+      Attribute_Address                |
+      Attribute_Aft                    |
+      Attribute_Alignment              |
+      Attribute_Base                   |
+      Attribute_Callable               |
+      Attribute_Constrained            |
+      Attribute_Count                  |
+      Attribute_Delta                  |
+      Attribute_Digits                 |
+      Attribute_Emax                   |
+      Attribute_Epsilon                |
+      Attribute_First                  |
+      Attribute_First_Bit              |
+      Attribute_Fore                   |
+      Attribute_Image                  |
+      Attribute_Large                  |
+      Attribute_Last                   |
+      Attribute_Last_Bit               |
+      Attribute_Leading_Part           |
+      Attribute_Length                 |
+      Attribute_Machine_Emax           |
+      Attribute_Machine_Emin           |
+      Attribute_Machine_Mantissa       |
+      Attribute_Machine_Overflows      |
+      Attribute_Machine_Radix          |
+      Attribute_Machine_Rounds         |
+      Attribute_Mantissa               |
+      Attribute_Pos                    |
+      Attribute_Position               |
+      Attribute_Pred                   |
+      Attribute_Range                  |
+      Attribute_Safe_Emax              |
+      Attribute_Safe_Large             |
+      Attribute_Safe_Small             |
+      Attribute_Size                   |
+      Attribute_Small                  |
+      Attribute_Storage_Size           |
+      Attribute_Succ                   |
+      Attribute_Terminated             |
+      Attribute_Val                    |
+      Attribute_Value                  |
+      Attribute_Width                  => True,
+      others                           => False);
 
    --  The following array is the list of attributes defined in the Ada 2005
    --  RM which are not defined in Ada 95. These are recognized in Ada 95 mode,
    --  but in Ada 95 they are considered to be implementation defined.
 
    Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'(
-      Attribute_Machine_Rounding  |
-      Attribute_Mod               |
-      Attribute_Priority          |
-      Attribute_Stream_Size       |
-      Attribute_Wide_Wide_Width   => True,
-      others                      => False);
+      Attribute_Machine_Rounding       |
+      Attribute_Mod                    |
+      Attribute_Priority               |
+      Attribute_Stream_Size            |
+      Attribute_Wide_Wide_Width        => True,
+      others                           => False);
 
    --  The following array contains all attributes that imply a modification
    --  of their prefixes or result in an access value. Such prefixes can be
@@ -147,13 +147,13 @@ package body Sem_Attr is
 
    Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Class_Array :=
       Attribute_Class_Array'(
-      Attribute_Access              |
-      Attribute_Address             |
-      Attribute_Input               |
-      Attribute_Read                |
-      Attribute_Unchecked_Access    |
-      Attribute_Unrestricted_Access => True,
-      others                        => False);
+      Attribute_Access                 |
+      Attribute_Address                |
+      Attribute_Input                  |
+      Attribute_Read                   |
+      Attribute_Unchecked_Access       |
+      Attribute_Unrestricted_Access    => True,
+      others                           => False);
 
    -----------------------
    -- Local_Subprograms --
@@ -1870,9 +1870,7 @@ package body Sem_Attr is
          end if;
       end Validate_Non_Static_Attribute_Function_Call;
 
-   -----------------------------------------------
-   -- Start of Processing for Analyze_Attribute --
-   -----------------------------------------------
+   --   Start of processing for Analyze_Attribute
 
    begin
       --  Immediate return if unrecognized attribute (already diagnosed
@@ -1897,9 +1895,9 @@ package body Sem_Attr is
          end if;
       end if;
 
-      --  Deal with Ada 2005 issues
+      --  Deal with Ada 2005 attributes that are
 
-      if Attribute_05 (Attr_Id) and then Ada_Version <= Ada_95 then
+      if Attribute_05 (Attr_Id) and then Ada_Version < Ada_2005 then
          Check_Restriction (No_Implementation_Attributes, N);
       end if;
 
@@ -6016,13 +6014,6 @@ package body Sem_Attr is
            Eval_Fat.Copy_Sign
              (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static);
 
-      -----------
-      -- Delta --
-      -----------
-
-      when Attribute_Delta =>
-         Fold_Ureal (N, Delta_Value (P_Type), True);
-
       --------------
       -- Definite --
       --------------
@@ -6032,6 +6023,13 @@ package body Sem_Attr is
            Boolean_Literals (not Is_Indefinite_Subtype (P_Entity)), Loc));
          Analyze_And_Resolve (N, Standard_Boolean);
 
+      -----------
+      -- Delta --
+      -----------
+
+      when Attribute_Delta =>
+         Fold_Ureal (N, Delta_Value (P_Type), True);
+
       ------------
       -- Denorm --
       ------------
index dadb7b1b5303ea74a8beaed6cfc090dab17cba93..2a1134f4e99161037863ef91f792c796f3a28669 100644 (file)
@@ -536,7 +536,7 @@ package body Sem_Ch13 is
                      if Present (CC)
                        and then not Error_Posted (Last_Bit (CC))
                        and then Static_Integer (Last_Bit (CC)) <
-                                Max_Machine_Scalar_Size
+                                                    Max_Machine_Scalar_Size
                      then
                         Num_CC := Num_CC + 1;
                         Comps (Num_CC) := Comp;
@@ -981,29 +981,6 @@ package body Sem_Ch13 is
                      Set_Is_Delayed_Aspect (Aspect);
                   end if;
 
-               --  Aspects corresponding to pragmas with two arguments, where
-               --  the first argument is a local name referring to the entity,
-               --  and the second argument is the aspect definition expression
-               --  which is an expression which must be delayed and analyzed.
-
-               when Aspect_Default_Component_Value |
-                    Aspect_Default_Value           =>
-
-                  --  Construct the pragma
-
-                  Aitem :=
-                    Make_Pragma (Loc,
-                      Pragma_Argument_Associations => New_List (
-                        New_Occurrence_Of (E, Loc),
-                        Relocate_Node (Expr)),
-                      Pragma_Identifier            =>
-                        Make_Identifier (Sloc (Id), Chars (Id)));
-
-                  --  These aspects do require delaying
-
-                  Delay_Required := True;
-                  Set_Is_Delayed_Aspect (Aspect);
-
                --  Aspects corresponding to pragmas with two arguments, where
                --  the first argument is a local name referring to the entity,
                --  and the second argument is the aspect definition expression
@@ -1049,6 +1026,45 @@ package body Sem_Ch13 is
 
                   Delay_Required := False;
 
+               --  Default_Value and Default_Component_Value aspects. These
+               --  are specially handled because they have no corresponding
+               --  pragmas or attributes.
+
+               when Aspect_Default_Value | Aspect_Default_Component_Value =>
+                  Error_Msg_Name_1 := Chars (Id);
+
+                  if not Is_Type (E) then
+                     Error_Msg_N ("aspect% can only apply to a type", Id);
+                     goto Continue;
+
+                  elsif not Is_First_Subtype (E) then
+                     Error_Msg_N ("aspect% cannot apply to subtype", Id);
+                     goto Continue;
+
+                  elsif A_Id = Aspect_Default_Value
+                    and then not Is_Scalar_Type (E)
+                  then
+                     Error_Msg_N
+                       ("aspect% can only be applied to scalar type", Id);
+                     goto Continue;
+
+                  elsif A_Id = Aspect_Default_Component_Value then
+                     if not Is_Array_Type (E) then
+                        Error_Msg_N
+                          ("aspect% can only be applied to array type", Id);
+                        goto Continue;
+                     elsif not Is_Scalar_Type (Component_Type (E)) then
+                        Error_Msg_N
+                          ("aspect% requires scalar components", Id);
+                        goto Continue;
+                     end if;
+                  end if;
+
+                  Aitem := Empty;
+                  Delay_Required := True;
+                  Set_Is_Delayed_Aspect (Aspect);
+                  Set_Has_Default_Aspect (Base_Type (Entity (Ent)));
+
                --  Aspects Pre/Post generate Precondition/Postcondition pragmas
                --  with a first argument that is the expression, and a second
                --  argument that is an informative message if the test fails.
@@ -1218,23 +1234,27 @@ package body Sem_Ch13 is
                   Delay_Required := True;
             end case;
 
-            Set_From_Aspect_Specification (Aitem, True);
-
             --  If a delay is required, we delay the freeze (not much point in
             --  delaying the aspect if we don't delay the freeze!). The pragma
-            --  or clause is then attached to the aspect specification which
-            --  is placed in the rep item list.
+            --  or attribute clause if there is one is then attached to the
+            --  aspect specification which is placed in the rep item list.
 
             if Delay_Required then
+               if Present (Aitem) then
+                  Set_From_Aspect_Specification (Aitem, True);
+                  Set_Is_Delayed_Aspect (Aitem);
+                  Set_Aspect_Rep_Item (Aspect, Aitem);
+               end if;
+
                Ensure_Freeze_Node (E);
-               Set_Is_Delayed_Aspect (Aitem);
                Set_Has_Delayed_Aspects (E);
-               Set_Aspect_Rep_Item (Aspect, Aitem);
                Record_Rep_Item (E, Aspect);
 
             --  If no delay required, insert the pragma/clause in the tree
 
             else
+               Set_From_Aspect_Specification (Aitem, True);
+
                --  If this is a compilation unit, we will put the pragma in
                --  the Pragmas_After list of the N_Compilation_Unit_Aux node.
 
@@ -1278,8 +1298,8 @@ package body Sem_Ch13 is
             end if;
          end;
 
-         <<Continue>>
-            Next (Aspect);
+      <<Continue>>
+         Next (Aspect);
       end loop Aspect_Loop;
    end Analyze_Aspect_Specifications;
 
@@ -1333,8 +1353,16 @@ package body Sem_Ch13 is
       Attr  : constant Name_Id      := Chars (N);
       Expr  : constant Node_Id      := Expression (N);
       Id    : constant Attribute_Id := Get_Attribute_Id (Attr);
-      Ent   : Entity_Id;
+
+      Ent : Entity_Id;
+      --  The entity of Nam after it is analyzed. In the case of an incomplete
+      --  type, this is the underlying type.
+
       U_Ent : Entity_Id;
+      --  The underlying entity to which the attribute applies. Generally this
+      --  is the Underlying_Type of Ent, except in the case where the clause
+      --  applies to full view of incomplete type or private type in which case
+      --  U_Ent is just a copy of Ent.
 
       FOnly : Boolean := False;
       --  Reset to True for subtype specific attribute (Alignment, Size)
@@ -1366,6 +1394,7 @@ package body Sem_Ch13 is
          Pnam : Entity_Id;
 
          Is_Read : constant Boolean := (TSS_Nam = TSS_Stream_Read);
+         --  True for Read attribute, false for other attributes
 
          function Has_Good_Profile (Subp : Entity_Id) return Boolean;
          --  Return true if the entity is a subprogram with an appropriate
@@ -1528,6 +1557,16 @@ package body Sem_Ch13 is
    --  Start of processing for Analyze_Attribute_Definition_Clause
 
    begin
+      --  The following code is a defense against recursion. Not clear that
+      --  this can happen legitimately, but perhaps some error situations
+      --  can cause it, and we did see this recursion during testing.
+
+      if Analyzed (N) then
+         return;
+      else
+         Set_Analyzed (N, True);
+      end if;
+
       --  Process Ignore_Rep_Clauses option
 
       if Ignore_Rep_Clauses then
@@ -1558,13 +1597,13 @@ package body Sem_Ch13 is
             --  legality, e.g. failing to provide a stream attribute for a
             --  type may make a program illegal.
 
-            when Attribute_External_Tag   |
-                 Attribute_Input          |
-                 Attribute_Output         |
-                 Attribute_Read           |
-                 Attribute_Storage_Pool   |
-                 Attribute_Storage_Size   |
-                 Attribute_Write          =>
+            when Attribute_External_Tag            |
+                 Attribute_Input                   |
+                 Attribute_Output                  |
+                 Attribute_Read                    |
+                 Attribute_Storage_Pool            |
+                 Attribute_Storage_Size            |
+                 Attribute_Write                   =>
                null;
 
             --  Other cases are errors ("attribute& cannot be set with
@@ -1890,6 +1929,7 @@ package body Sem_Ch13 is
                   --  check till after code generation to take full advantage
                   --  of the annotation done by the back end. This entry is
                   --  only made if the address clause comes from source.
+
                   --  If the entity has a generic type, the check will be
                   --  performed in the instance if the actual type justifies
                   --  it, and we do not insert the clause in the table to
@@ -2253,7 +2293,6 @@ package body Sem_Ch13 is
                  ("size cannot be given for unconstrained array", Nam);
 
             elsif Size /= No_Uint then
-
                if VM_Target /= No_VM and then not GNAT_Mode then
 
                   --  Size clause is not handled properly on VM targets.
@@ -2443,9 +2482,10 @@ package body Sem_Ch13 is
             end if;
 
             --  The Stack_Bounded_Pool is used internally for implementing
-            --  access types with a Storage_Size. Since it only work
-            --  properly when used on one specific type, we need to check
-            --  that it is not hijacked improperly:
+            --  access types with a Storage_Size. Since it only work properly
+            --  when used on one specific type, we need to check that it is not
+            --  hijacked improperly:
+
             --    type T is access Integer;
             --    for T'Storage_Size use n;
             --    type Q is access Float;
@@ -2673,9 +2713,9 @@ package body Sem_Ch13 is
               ("attribute& cannot be set with definition clause", N);
       end case;
 
-      --  The test for the type being frozen must be performed after
-      --  any expression the clause has been analyzed since the expression
-      --  itself might cause freezing that makes the clause illegal.
+      --  The test for the type being frozen must be performed after any
+      --  expression the clause has been analyzed since the expression itself
+      --  might cause freezing that makes the clause illegal.
 
       if Rep_Item_Too_Late (U_Ent, N, FOnly) then
          return;
@@ -3198,11 +3238,12 @@ package body Sem_Ch13 is
          Build_Predicate_Function (E, N);
       end if;
 
-      --  If type has delayed aspects, this is where we do the preanalysis
-      --  at the freeze point, as part of the consistent visibility check.
-      --  Note that this must be done after calling Build_Predicate_Function,
-      --  since that call marks occurrences of the subtype name in the saved
-      --  expression so that they will not cause trouble in the preanalysis.
+      --  If type has delayed aspects, this is where we do the preanalysis at
+      --  the freeze point, as part of the consistent visibility check. Note
+      --  that this must be done after calling Build_Predicate_Function or
+      --  Build_Invariant_Procedure since these subprograms fix occurrences of
+      --  the subtype name in the saved expression so that they will not cause
+      --  trouble in the preanalysis.
 
       if Has_Delayed_Aspects (E) then
          declare
@@ -6959,7 +7000,9 @@ package body Sem_Ch13 is
 
       if Is_Incomplete_Or_Private_Type (T)
         and then No (Underlying_Type (T))
-        and then Get_Pragma_Id (N) /= Pragma_Import
+        and then
+          (Nkind (N) /= N_Pragma
+             or else Get_Pragma_Id (N) /= Pragma_Import)
       then
          Error_Msg_N
            ("representation item must be after full type declaration", N);
index bd0f9187cc6c4250227cb193b39e7b7a45a4f383..562fad6affa412ff5403d7010fce2ac8f169b68c 100644 (file)
@@ -2261,7 +2261,7 @@ package body Sem_Ch5 is
             --  Find the Element_Type in the package instance that defines the
             --  container type.
 
-            Ent := First_Entity (Scope (Typ));
+            Ent := First_Entity (Scope (Base_Type (Typ)));
             while Present (Ent) loop
                if Chars (Ent) = Name_Element_Type then
                   Set_Etype (Def_Id, Ent);
@@ -2274,7 +2274,7 @@ package body Sem_Ch5 is
          else
             --  Find the Cursor type in similar fashion
 
-            Ent := First_Entity (Scope (Typ));
+            Ent := First_Entity (Scope (Base_Type (Typ)));
             while Present (Ent) loop
                if Chars (Ent) = Name_Cursor then
                   Set_Etype (Def_Id, Ent);
index c2cb3d4cc69212ae625d05aec8547d768f181de4..328c2f95a9beeb417935b6ee6cc55e078161f4cc 100644 (file)
@@ -7352,139 +7352,6 @@ package body Sem_Prag is
             Debug_Pragmas_Enabled :=
               Chars (Get_Pragma_Arg (Arg1)) = Name_Check;
 
-         -----------------------------
-         -- Default_Component_Value --
-         -----------------------------
-
-         when Pragma_Default_Component_Value => declare
-            Arg : Node_Id;
-            E   : Entity_Id;
-
-         begin
-            GNAT_Pragma;
-            Check_Arg_Count (2);
-            Check_Arg_Is_Local_Name (Arg1);
-
-            Arg := Get_Pragma_Arg (Arg1);
-            Analyze (Arg);
-
-            if Etype (Arg) = Any_Type then
-               return;
-            end if;
-
-            if not Is_Entity_Name (Arg)
-              or else not Is_Array_Type (Entity (Arg))
-            then
-               Error_Pragma_Arg ("pragma% requires an array type", Arg1);
-            end if;
-
-            Check_First_Subtype (Arg1);
-
-            E := Entity (Arg);
-            Check_Duplicate_Pragma (E);
-
-            --  Check for rep item too early or too late, but skip this if
-            --  the pragma comes from the corresponding aspect, since we do
-            --  not need the checks, and more importantly, the pragma is on
-            --  the rep item chain alreay, and must not be put there twice!
-
-            if not From_Aspect_Specification (N) then
-               if Rep_Item_Too_Early (E, N)
-                    or else
-                  Rep_Item_Too_Late (E, N)
-               then
-                  return;
-               end if;
-            end if;
-
-            --  Analyze the default value
-
-            Arg := Get_Pragma_Arg (Arg2);
-            Analyze_And_Resolve (Arg, Component_Type (E));
-
-            if not Is_OK_Static_Expression (Arg) then
-               Flag_Non_Static_Expr
-                 ("non-static expression not allowed for " &
-                  "Default_Component_Value",
-                  Arg2);
-               raise Pragma_Exit;
-            end if;
-
-            --  Set the flag on the root type and then check for Rep_Item too
-            --  early or too late, the latter call chains the pragma onto the
-            --  Rep_Item chain.
-
-            Set_Has_Default_Component_Value (Base_Type (E));
-         end;
-
-         -------------------
-         -- Default_Value --
-         -------------------
-
-         when Pragma_Default_Value => declare
-            Arg : Node_Id;
-            E   : Entity_Id;
-
-         begin
-            --  Error checks
-
-            GNAT_Pragma;
-            Check_Arg_Count (2);
-            Check_Arg_Is_Local_Name (Arg1);
-
-            Arg := Get_Pragma_Arg (Arg1);
-            Analyze (Arg);
-
-            if Etype (Arg) = Any_Type then
-               return;
-            end if;
-
-            if not Is_Entity_Name (Arg)
-              or else not Is_Scalar_Type (Entity (Arg))
-            then
-               Error_Pragma_Arg ("pragma% requires a scalar type", Arg1);
-            end if;
-
-            Check_First_Subtype (Arg1);
-
-            E := Entity (Arg);
-            Check_Duplicate_Pragma (E);
-
-            --  Check for rep item too early or too late, but skip this if
-            --  the pragma comes from the corresponding aspect, since we do
-            --  not need the checks, and more importantly, the pragma is on
-            --  the rep item chain alreay, and must not be put there twice!
-
-            if not From_Aspect_Specification (N) then
-               if Rep_Item_Too_Early (E, N)
-                    or else
-                  Rep_Item_Too_Late (E, N)
-               then
-                  return;
-               end if;
-            end if;
-
-            --  Analyze the default value. Note that we must do that after
-            --  checking for Rep_Item_Too_Late since this resolution will
-            --  freeze the type involved.
-
-            Arg := Get_Pragma_Arg (Arg2);
-            Analyze_And_Resolve (Arg, E);
-
-            if not Is_OK_Static_Expression (Arg) then
-               Flag_Non_Static_Expr
-                 ("non-static expression not allowed for Default_Value",
-                  Arg2);
-               raise Pragma_Exit;
-            end if;
-
-            --  Set the flag on the root type and then check for Rep_Item too
-            --  early or too late, the latter call chains the pragma onto the
-            --  Rep_Item chain.
-
-            Set_Has_Default_Value (Base_Type (E));
-         end;
-
          ---------------------
          -- Detect_Blocking --
          ---------------------
@@ -14111,8 +13978,6 @@ package body Sem_Prag is
       Pragma_Convention_Identifier         =>  0,
       Pragma_Debug                         => -1,
       Pragma_Debug_Policy                  =>  0,
-      Pragma_Default_Value                 => -1,
-      Pragma_Default_Component_Value       => -1,
       Pragma_Detect_Blocking               => -1,
       Pragma_Default_Storage_Pool          => -1,
       Pragma_Dimension                     => -1,
index f10aefaddf9a482d6e4d9dc7f0943bc3b18b6bdf..5360f4eaa1f6f8a774fc5e817d9d04071237bab8 100644 (file)
@@ -137,6 +137,8 @@ package Snames is
    --  Names of aspects for which there are no matching pragmas or attributes
    --  so that they need to be included for aspect specification use.
 
+   Name_Default_Value                  : constant Name_Id := N + $;
+   Name_Default_Component_Value        : constant Name_Id := N + $;
    Name_Dynamic_Predicate              : constant Name_Id := N + $;
    Name_Post                           : constant Name_Id := N + $;
    Name_Pre                            : constant Name_Id := N + $;
@@ -447,8 +449,6 @@ package Snames is
    Name_CPP_Vtable                     : constant Name_Id := N + $; -- GNAT
    Name_CPU                            : constant Name_Id := N + $; -- Ada 12
    Name_Debug                          : constant Name_Id := N + $; -- GNAT
-   Name_Default_Value                  : constant Name_Id := N + $; -- GNAT
-   Name_Default_Component_Value        : constant Name_Id := N + $; -- GNAT
    Name_Dimension                      : constant Name_Id := N + $; -- GNAT
    Name_Elaborate                      : constant Name_Id := N + $; -- Ada 83
    Name_Elaborate_All                  : constant Name_Id := N + $;
@@ -1554,8 +1554,6 @@ package Snames is
       Pragma_CPP_Vtable,
       Pragma_CPU,
       Pragma_Debug,
-      Pragma_Default_Value,
-      Pragma_Default_Component_Value,
       Pragma_Dimension,
       Pragma_Elaborate,
       Pragma_Elaborate_All,