From: Arnaud Charlet Date: Tue, 2 Aug 2011 13:16:09 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=a01b9df6570850b2202158e9914979878860c77d;p=gcc.git [multiple changes] 2011-08-02 Robert Dewar * sem_attr.adb: Minor reformatting. 2011-08-02 Ed Falis * init.c: Revert previous change. 2011-08-02 Robert Dewar * 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 * 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 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 9b6d9734b86..09f5a9552c2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,34 @@ +2011-08-02 Robert Dewar + + * sem_attr.adb: Minor reformatting. + +2011-08-02 Robert Dewar + + * 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 + + * 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 * sem_ch5.adb (Analyze_Iteration_Scheme): For an Ada2012 iterator with @@ -182,11 +213,6 @@ * s-stusta.adb (Print): Make sure Pos is always initialized to a suitable value. -2011-08-02 Ed Falis - - * init.c: Fix conditional compilation so that the fp initialization is - peformed for the MILS VxWorks Guest OS. - 2011-08-02 Geert Bosch * a-calfor.adb (Image): Simplify, removing unnecessary uses of 'Image. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index c050776911b..fedf63b70da 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 45dd3b4778f..b319cf4b578 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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); diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 47e39c4f38b..39b32cec46d 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -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); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 7eb6c99f272..99a14fdfffc 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -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. diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index beb74b562bb..91431efc680 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -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; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index f102cf9eafc..854b1a0ca89 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -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, diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index f1a2b829bd0..06313c84e2f 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -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; diff --git a/gcc/ada/init.c b/gcc/ada/init.c index df0bb932ca7..822837c0d19 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -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; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index d3959b74d0b..10237a55127 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -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 | diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index f75f36e8e95..08761d8fd60 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -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 -- ------------ diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index dadb7b1b530..2a1134f4e99 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -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; - <> - Next (Aspect); + <> + 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); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index bd0f9187cc6..562fad6affa 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -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); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index c2cb3d4cc69..328c2f95a9b 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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, diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index f10aefaddf9..5360f4eaa1f 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -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,