diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 25 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 76 | ||||
| -rw-r--r-- | gcc/ada/restrict.ads | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 76 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 30 | ||||
| -rw-r--r-- | gcc/ada/sem_ch5.adb | 112 |
6 files changed, 193 insertions, 127 deletions
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index c89582b3a4e..be053b59ddd 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -5900,22 +5900,13 @@ package body Exp_Ch4 is elsif Nkind (Parent (N)) = N_Case_Statement and then Etype (Node (Dcon)) /= Etype (Disc) then - -- RBKD is suspicious of the following code. The - -- call to New_Copy instead of New_Copy_Tree is - -- suspicious, and the call to Analyze instead - -- of Analyze_And_Resolve is also suspicious ??? - - -- Wouldn't it be good enough to do a perfectly - -- normal Analyze_And_Resolve call using the - -- subtype of the discriminant here??? - Rewrite (N, Make_Qualified_Expression (Loc, Subtype_Mark => New_Occurrence_Of (Etype (Disc), Loc), Expression => - New_Copy (Node (Dcon)))); - Analyze (N); + New_Copy_Tree (Node (Dcon)))); + Analyze_And_Resolve (N, Etype (Disc)); -- In case that comes out as a static expression, -- reset it (a selected component is never static). @@ -5924,13 +5915,15 @@ package body Exp_Ch4 is return; -- Otherwise we can just copy the constraint, but the - -- result is certainly not static! - - -- Again the New_Copy here and the failure to even - -- to an analyze call is uneasy ??? + -- result is certainly not static! In some cases the + -- discriminant constraint has been analyzed in the + -- context of the original subtype indication, but for + -- itypes the constraint might not have been analyzed + -- yet, and this must be done now. else - Rewrite (N, New_Copy (Node (Dcon))); + Rewrite (N, New_Copy_Tree (Node (Dcon))); + Analyze_And_Resolve (N); Set_Is_Static_Expression (N, False); return; end if; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index eb6abd02f34..0339479b0e2 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -1050,77 +1050,13 @@ package body Exp_Ch7 is if No (Wrap_Node) then null; - elsif Nkind (Wrap_Node) = N_Iteration_Scheme then - - -- Create a declaration followed by an assignment, so that - -- the assignment can have its own transient scope. - -- We generate the equivalent of: - - -- type Ptr is access all expr_type; - -- Var : Ptr; - -- begin - -- Var := Expr'reference; - -- end; - - -- This closely resembles what is done in Remove_Side_Effect, - -- but it has to be done here, before the analysis of the call - -- is completed. - - declare - Ptr_Typ : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); - Ptr : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); - - Expr_Type : constant Entity_Id := Etype (N); - New_Expr : constant Node_Id := Relocate_Node (N); - Decl : Node_Id; - Ptr_Typ_Decl : Node_Id; - Stmt : Node_Id; + -- If the node to wrap is an iteration_scheme, the expression is + -- one of the bounds, and the expansion will make an explicit + -- declaration for it (see Analyze_Iteration_Scheme, sem_ch5.adb), + -- so do not apply any transformations here. - begin - Ptr_Typ_Decl := - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Ptr_Typ, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - All_Present => True, - Subtype_Indication => - New_Reference_To (Expr_Type, Loc))); - - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Ptr, - Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc)); - - Set_Etype (Ptr, Ptr_Typ); - Stmt := - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Ptr, Loc), - Expression => Make_Reference (Loc, New_Expr)); - - Set_Analyzed (New_Expr, False); - - Insert_List_Before_And_Analyze - (Parent (Wrap_Node), - New_List ( - Ptr_Typ_Decl, - Decl, - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - New_List (Stmt))))); - - Rewrite (N, - Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Ptr, Loc))); - Analyze_And_Resolve (N, Expr_Type); - - end; - - -- Transient scope is required + elsif Nkind (Wrap_Node) = N_Iteration_Scheme then + null; else New_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B')); diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index b2658d03331..364b6507ad3 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -93,7 +93,6 @@ package Restrict is (No_IO, "text_io "), (No_IO, "a-witeio"), (No_Task_Attributes_Package, "a-tasatt"), - (No_Streams, "a-stream"), (No_Unchecked_Conversion, "a-unccon"), (No_Unchecked_Conversion, "unchconv"), (No_Unchecked_Deallocation, "a-uncdea"), diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index fe1cf825923..78d714e848e 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -459,7 +459,7 @@ package body Sem_Ch3 is -- build the associated Implicit type name. procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id); - -- Build subtype of a signed or modular integer type. + -- Build subtype of a signed or modular integer type procedure Constrain_Ordinary_Fixed (Def_Id : Node_Id; S : Node_Id); -- Constrain an ordinary fixed point type with a range constraint, and @@ -1415,7 +1415,7 @@ package body Sem_Ch3 is elsif It.Typ = Universal_Real or else It.Typ = Universal_Integer then - -- Choose universal interpretation over any other. + -- Choose universal interpretation over any other T := It.Typ; exit; @@ -1806,6 +1806,18 @@ package body Sem_Ch3 is Apply_Static_Length_Check (E, T); end if; + -- If the No_Streams restriction is set, check that the type of the + -- object is not, and does not contain, any subtype derived from + -- Ada.Streams.Root_Stream_Type. Note that we guard the call to + -- Has_Stream just for efficiency reasons. There is no point in + -- spending time on a Has_Stream check if the restriction is not set. + + if Restrictions.Set (No_Streams) then + if Has_Stream (T) then + Check_Restriction (No_Streams, N); + end if; + end if; + -- Abstract type is never permitted for a variable or constant. -- Note: we inhibit this check for objects that do not come from -- source because there is at least one case (the expansion of @@ -1917,7 +1929,7 @@ package body Sem_Ch3 is elsif Nkind (E) = N_Raise_Constraint_Error then - -- Aggregate is statically illegal. Place back in declaration. + -- Aggregate is statically illegal. Place back in declaration Set_Expression (N, E); Set_No_Initialization (N, False); @@ -2759,7 +2771,7 @@ package body Sem_Ch3 is when N_Derived_Type_Definition => null; - -- For record types, discriminants are allowed. + -- For record types, discriminants are allowed when N_Record_Definition => null; @@ -2940,7 +2952,7 @@ package body Sem_Ch3 is Process_Non_Static_Choice => Non_Static_Choice_Error, Process_Associated_Node => Process_Declarations); use Variant_Choices_Processing; - -- Instantiation of the generic choice processing package. + -- Instantiation of the generic choice processing package ----------------------------- -- Non_Static_Choice_Error -- @@ -2967,7 +2979,7 @@ package body Sem_Ch3 is end if; end Process_Declarations; - -- Variables local to Analyze_Case_Statement. + -- Variables local to Analyze_Case_Statement Discr_Name : Node_Id; Discr_Type : Entity_Id; @@ -4180,7 +4192,7 @@ package body Sem_Ch3 is end if; end if; - -- Build partial view of derived type from partial view of parent. + -- Build partial view of derived type from partial view of parent Build_Derived_Record_Type (N, Parent_Type, Derived_Type, Derive_Subps); @@ -4388,7 +4400,7 @@ package body Sem_Ch3 is Copy_And_Build; Exchange_Declarations (Full_P); - -- Otherwise it is a local derivation. + -- Otherwise it is a local derivation else Copy_And_Build; @@ -4545,7 +4557,7 @@ package body Sem_Ch3 is -- in the derived type definition, then the discriminant is said to be -- "specified" by that derived type definition. - -- 3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES. + -- 3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES -- We have spoken about stored discriminants in point 1 (introduction) -- above. There are two sort of stored discriminants: implicit and @@ -4720,7 +4732,7 @@ package body Sem_Ch3 is -- Discriminant_Constraint from Der so that when parameter conformance is -- checked when P is overridden, no semantic errors are flagged. - -- 6. SECOND TRANSFORMATION FOR DERIVED RECORDS. + -- 6. SECOND TRANSFORMATION FOR DERIVED RECORDS -- Regardless of whether we are dealing with a tagged or untagged type -- we will transform all derived type declarations of the form @@ -4755,9 +4767,7 @@ package body Sem_Ch3 is -- type T2 (X : positive) is new R (1, X) [with null record]; -- As explained in 6. above, T1 is rewritten as - -- type T1 (D1, D2 : Positive) is new R (D1, D2) [with null record]; - -- which makes the treatment for T1 and T2 identical. -- What we want when inheriting S, is that references to D1 and D2 in R are @@ -4877,7 +4887,7 @@ package body Sem_Ch3 is -- subtype T is BaseT (1); -- end; - -- (strictly speaking the above is incorrect Ada). + -- (strictly speaking the above is incorrect Ada) -- From the semantic standpoint the private view of private extension T -- should be flagged as constrained since one can clearly have @@ -5037,7 +5047,7 @@ package body Sem_Ch3 is and then not Discriminant_Specs and then (Is_Constrained (Parent_Type) or else Constraint_Present) then - -- First, we must analyze the constraint (see comment in point 5.). + -- First, we must analyze the constraint (see comment in point 5.) if Constraint_Present then New_Discrs := Build_Discriminant_Constraints (Parent_Type, Indic); @@ -5379,6 +5389,7 @@ package body Sem_Ch3 is end if; if not Has_Unknown_Discriminants (Derived_Type) + and then not Has_Unknown_Discriminants (Parent_Base) and then Has_Discriminants (Parent_Type) then Inherit_Discrims := True; @@ -5407,7 +5418,7 @@ package body Sem_Ch3 is or else Has_Unknown_Discriminants (Derived_Type))); end if; - -- STEP 3: initialize fields of derived type. + -- STEP 3: initialize fields of derived type Set_Is_Tagged_Type (Derived_Type, Is_Tagged); Set_Stored_Constraint (Derived_Type, No_Elist); @@ -5441,7 +5452,7 @@ package body Sem_Ch3 is (Derived_Type, Finalize_Storage_Only (Parent_Type)); end if; - -- Set fields for private derived types. + -- Set fields for private derived types if Is_Private_Type (Derived_Type) then Set_Depends_On_Private (Derived_Type, True); @@ -5901,7 +5912,7 @@ package body Sem_Ch3 is while Present (Constr) loop - -- Positional association forbidden after a named association. + -- Positional association forbidden after a named association if Nkind (Constr) /= N_Discriminant_Association then Error_Msg_N ("positional association follows named one", Constr); @@ -6025,7 +6036,7 @@ package body Sem_Ch3 is end if; end loop; - -- Determine if there are discriminant expressions in the constraint. + -- Determine if there are discriminant expressions in the constraint for J in Discr_Expr'Range loop if Denotes_Discriminant (Discr_Expr (J), Check_Protected => True) then @@ -6813,7 +6824,7 @@ package body Sem_Ch3 is begin if Has_Discriminants (T) then - -- Make the discriminants visible to component declarations. + -- Make the discriminants visible to component declarations declare D : Entity_Id := First_Discriminant (T); @@ -7752,7 +7763,7 @@ package body Sem_Ch3 is Set_Parent (Subtyp_Decl, Parent (Related_Node)); - -- Itypes must be analyzed with checks off (see itypes.ads). + -- Itypes must be analyzed with checks off (see package Itypes) Analyze (Subtyp_Decl, Suppress => All_Checks); @@ -7859,7 +7870,7 @@ package body Sem_Ch3 is return True; end if; - -- In all other cases we have something wrong. + -- In all other cases we have something wrong return False; end Is_Discriminant; @@ -8252,7 +8263,7 @@ package body Sem_Ch3 is (Nkind (S) = N_Attribute_Reference and then Attribute_Name (S) = Name_Range) then - -- A Range attribute will transformed into N_Range by Resolve. + -- A Range attribute will transformed into N_Range by Resolve Analyze (S); Set_Etype (S, T); @@ -8488,7 +8499,7 @@ package body Sem_Ch3 is then return; - -- Here we do the analysis of the range. + -- Here we do the analysis of the range -- Note: we do this manually, since if we do a normal Analyze and -- Resolve call, there are problems with the conversions used for @@ -8642,7 +8653,7 @@ package body Sem_Ch3 is -- Collect parent type components that do not appear in a variant part procedure Create_All_Components; - -- Iterate over Comp_List to create the components of the subtype. + -- Iterate over Comp_List to create the components of the subtype function Create_Component (Old_Compon : Entity_Id) return Entity_Id; -- Creates a new component from Old_Compon, copying all the fields from @@ -9822,7 +9833,7 @@ package body Sem_Ch3 is Discriminant : Entity_Id; function Type_With_Explicit_Discrims (Id : Entity_Id) return Entity_Id; - -- Find the nearest type that actually specifies discriminants. + -- Find the nearest type that actually specifies discriminants --------------------------------- -- Type_With_Explicit_Discrims -- @@ -10101,7 +10112,7 @@ package body Sem_Ch3 is T := Empty; Array_Type_Declaration (T, Obj_Def); - -- Create an explicit subtype whenever possible. + -- Create an explicit subtype whenever possible elsif Nkind (P) /= N_Component_Declaration and then Def_Kind = N_Subtype_Indication @@ -10337,7 +10348,7 @@ package body Sem_Ch3 is -- Get_Discriminant_Value -- ---------------------------- - -- This is the situation... + -- This is the situation: -- There is a non-derived type @@ -10709,7 +10720,7 @@ package body Sem_Ch3 is while Present (Discrim) loop Corr_Discrim := Corresponding_Discriminant (Discrim); - -- Corr_Discrimm could be missing in an error situation. + -- Corr_Discrimm could be missing in an error situation if Present (Corr_Discrim) and then Original_Record_Component (Corr_Discrim) = Old_C @@ -10746,7 +10757,7 @@ package body Sem_Ch3 is Append_Elmt (Derived_Base, Assoc_List); end if; - -- Inherit parent discriminants if needed. + -- Inherit parent discriminants if needed if Inherit_Discr then Parent_Discrim := First_Discriminant (Parent_Base); @@ -10756,7 +10767,7 @@ package body Sem_Ch3 is end loop; end if; - -- Create explicit stored discrims for untagged types when necessary. + -- Create explicit stored discrims for untagged types when necessary if not Has_Unknown_Discriminants (Derived_Base) and then Has_Discriminants (Parent_Base) @@ -11915,7 +11926,7 @@ package body Sem_Ch3 is Set_Original_Record_Component (Id, Id); - -- Create the discriminal for the discriminant. + -- Create the discriminal for the discriminant Build_Discriminal (Id); @@ -12852,7 +12863,8 @@ package body Sem_Ch3 is -- expanded as part of the freezing actions if it is not a CPP_Class. if Is_Tagged then - -- Do not add the tag unless we are in expansion mode. + + -- Do not add the tag unless we are in expansion mode if Expander_Active then Tag_Comp := Make_Defining_Identifier (Sloc (Def), Name_uTag); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index b71e1f9aaeb..2629396cf1b 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -324,7 +324,7 @@ package body Sem_Ch4 is procedure Analyze_Allocator (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Sav_Errs : constant Nat := Serious_Errors_Detected; - E : Node_Id := Expression (N); + E : Node_Id := Expression (N); Acc_Type : Entity_Id; Type_Id : Entity_Id; @@ -498,6 +498,18 @@ package body Sem_Ch4 is Check_Restriction (No_Task_Allocators, N); end if; + -- If the No_Streams restriction is set, check that the type of the + -- object is not, and does not contain, any subtype derived from + -- Ada.Streams.Root_Stream_Type. Note that we guard the call to + -- Has_Stream just for efficiency reasons. There is no point in + -- spending time on a Has_Stream check if the restriction is not set. + + if Restrictions.Set (No_Streams) then + if Has_Stream (Designated_Type (Acc_Type)) then + Check_Restriction (No_Streams, N); + end if; + end if; + Set_Etype (N, Acc_Type); if not Is_Library_Level_Entity (Acc_Type) then @@ -1662,7 +1674,7 @@ package body Sem_Ch4 is Process_Function_Call; elsif Nkind (P) = N_Selected_Component - and then Ekind (Entity (Selector_Name (P))) = E_Function + and then Is_Overloadable (Entity (Selector_Name (P))) then Process_Function_Call; @@ -2614,11 +2626,11 @@ package body Sem_Ch4 is or else (Nkind (Parent_N) = N_Attribute_Reference and then (Attribute_Name (Parent_N) = Name_First - or else + or else Attribute_Name (Parent_N) = Name_Last - or else + or else Attribute_Name (Parent_N) = Name_Length - or else + or else Attribute_Name (Parent_N) = Name_Range))) then Set_Etype (N, Etype (Comp)); @@ -2630,7 +2642,10 @@ package body Sem_Ch4 is -- not make an actual subtype, we end up getting a direct -- reference to a discriminant which will not do. - else + -- Comment needs revision, "in all other cases" does not + -- reasonably describe the situation below with an elsif??? + + elsif Expander_Active then Act_Decl := Build_Actual_Subtype_Of_Component (Etype (Comp), N); Insert_Action (N, Act_Decl); @@ -2652,6 +2667,9 @@ package body Sem_Ch4 is Set_Etype (N, Subt); end; end if; + + else + Set_Etype (N, Etype (Comp)); end if; return; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 1aff311a343..99e10d17b26 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1105,12 +1105,111 @@ package body Sem_Ch5 is ------------------------------ procedure Analyze_Iteration_Scheme (N : Node_Id) is + + procedure Process_Bounds (R : Node_Id); + -- If the iteration is given by a range, create temporaries and + -- assignment statements block to capture the bounds and perform + -- required finalization actions in case a bound includes a function + -- call that uses the temporary stack. + procedure Check_Controlled_Array_Attribute (DS : Node_Id); -- If the bounds are given by a 'Range reference on a function call -- that returns a controlled array, introduce an explicit declaration -- to capture the bounds, so that the function result can be finalized -- in timely fashion. + -------------------- + -- Process_Bounds -- + -------------------- + + procedure Process_Bounds (R : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Lo : constant Node_Id := Low_Bound (R); + Hi : constant Node_Id := High_Bound (R); + New_Lo_Bound : Node_Id := Empty; + New_Hi_Bound : Node_Id := Empty; + Typ : constant Entity_Id := Etype (R); + + function One_Bound (Bound : Node_Id) return Node_Id; + -- Create one declaration followed by one assignment statement + -- to capture the value of bound. We create a separate assignment + -- in order to force the creation of a block in case the bound + -- contains a call that uses the secondary stack. + + --------------- + -- One_Bound -- + --------------- + + function One_Bound (Bound : Node_Id) return Node_Id is + Assign : Node_Id; + Id : Entity_Id; + Decl : Node_Id; + + begin + -- If the bound is a constant or an object, no need for a + -- separate declaration. If the bound is the result of previous + -- expansion it is already analyzed and should not be modified. + + if Nkind (Bound) = N_Integer_Literal + or else Is_Entity_Name (Bound) + or else Analyzed (Bound) + then + Resolve (Bound, Typ); + return Bound; + end if; + + Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('S')); + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Id, + Object_Definition => New_Occurrence_Of (Typ, Loc)); + + Insert_Before (Parent (N), Decl); + Analyze (Decl); + + Assign := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Id, Loc), + Expression => Relocate_Node (Bound)); + + Save_Interps (Bound, Expression (Assign)); + Insert_Before (Parent (N), Assign); + Analyze (Assign); + + Rewrite (Bound, New_Occurrence_Of (Id, Loc)); + + if Nkind (Assign) = N_Assignment_Statement then + return Expression (Assign); + else + return Bound; + end if; + end One_Bound; + + -- Start of processing for Process_Bounds + + begin + New_Lo_Bound := One_Bound (Lo); + New_Hi_Bound := One_Bound (Hi); + + -- Propagate staticness to loop range itself, in case the + -- corresponding subtype is static. + + if New_Lo_Bound /= Lo + and then Is_Static_Expression (New_Lo_Bound) + then + Rewrite (Low_Bound (R), New_Copy (New_Lo_Bound)); + end if; + + if New_Hi_Bound /= Hi + and then Is_Static_Expression (New_Hi_Bound) + then + Rewrite (High_Bound (R), New_Copy (New_Hi_Bound)); + end if; + end Process_Bounds; + -------------------------------------- -- Check_Controlled_Array_Attribute -- -------------------------------------- @@ -1212,9 +1311,17 @@ package body Sem_Ch5 is end if; end; - -- Now analyze the subtype definition + -- Now analyze the subtype definition. If it is + -- a range, create temporaries for bounds. - Analyze (DS); + if Nkind (DS) = N_Range + and then Expander_Active + then + Pre_Analyze_And_Resolve (DS); + Process_Bounds (DS); + else + Analyze (DS); + end if; if DS = Error then return; @@ -1238,6 +1345,7 @@ package body Sem_Ch5 is end if; Check_Controlled_Array_Attribute (DS); + Make_Index (DS, LP); Set_Ekind (Id, E_Loop_Parameter); |
