diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 54b32b47e36..f39e478e8e7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,38 @@ +2014-08-01 Tristan Gingold + + * sem_ch9.adb (Analyze_Task_Type_Declaration): Move code from ... + * exp_ch9.adb (Make_Task_Create_Call): ... here. + +2014-08-01 Vincent Celier + + * gnat1drv.adb: Do not try to get the target parameters when + invoked with -gnats. + +2014-08-01 Hristian Kirtchev + + * exp_ch7.adb (Find_Last_Init): Nothing to do for an object + declaration subject to No_Initialization. + +2014-08-01 Ed Schonberg + + * sem_aggr.adb (Resolve_Array_Aggregate): Reject choice that + is a subtype with dynamic predicates, or a non-static subtype + with predicates. + * sem_ch3.adb (Analyze_Number_Declaration): Reject qualified + expression if subtype has a dynamic predicate. + (Constrain_Index): Reject subtype indication if subtype mark + has predicates. + (Inerit_Predicate_Flags): Inherit Has_Predicates as well. + (Make_Index): If index is a subtype indication, itype inhereits + predicate flags for subsequent testing. + * sem_ch5.adb (Analyze_Loop_Parameter_Specification): New + procedure Check_Predicate_Use, to reject illegal uses of domains + of iteration that have dynamic predicates. + * sem_res.adb (Resolve_Slice): Reject slices given by a subtype + indication to which a predicate applies. + * sem_util.adb (Bad_Predicated_Subtype_Use): Add guard to + prevent cascaded errors when subtype is invalid. + 2014-08-01 Robert Dewar * sem_ch10.adb: Minor reformatting. diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 7d1526ca8c9..e2951801f8c 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -2449,6 +2449,15 @@ package body Exp_Ch7 is Next (Stmt); end loop; + -- Nothing to do for an object with supporessed initialization. + -- Note that this check is not performed at the beginning of the + -- routine because a declaration marked with No_Initialization + -- may still be initialized by a build-in-place call (the case + -- above). + + elsif No_Initialization (Decl) then + return; + -- In all other cases the initialization calls follow the related -- object. The general structure of object initialization built by -- routine Default_Initialize_Object is as follows: diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 3cacc77fed3..d01e849c88f 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -14013,20 +14013,6 @@ package body Exp_Ch9 is Ttyp := Corresponding_Concurrent_Type (Task_Rec); Tnam := Chars (Ttyp); - -- The sequential partition elaboration policy is supported only in the - -- restricted profile. - - -- This test should be in sem_ch9, not here ??? - - if Partition_Elaboration_Policy = 'S' - and then not Restricted_Profile - then - Error_Msg_N - ("sequential elaboration supported only in restricted profile", - Task_Rec); - return Make_Null_Statement (Loc); - end if; - -- Get task declaration. In the case of a task type declaration, this is -- simply the parent of the task type entity. In the single task -- declaration, this parent will be the implicit type, and we can find diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 6e6b5c53430..536c321e3c1 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -863,53 +863,65 @@ begin Opt.Compilation_Time := System.OS_Lib.Current_Time_String; - -- Acquire target parameters from system.ads (source of package System) + -- Get the target parameters only when -gnats is not used, to avoid + -- failing when there is no default runtime. - Targparm_Acquire : declare - use Sinput; + if Operating_Mode /= Check_Syntax then - S : Source_File_Index; - N : File_Name_Type; + -- Acquire target parameters from system.ads (package System source) + -- System). - begin - Name_Buffer (1 .. 10) := "system.ads"; - Name_Len := 10; - N := Name_Find; - S := Load_Source_File (N); + Targparm_Acquire : declare + use Sinput; - if S = No_Source_File then - Write_Line - ("fatal error, run-time library not installed correctly"); - Write_Line ("cannot locate file system.ads"); - raise Unrecoverable_Error; + S : Source_File_Index; + N : File_Name_Type; - -- Remember source index of system.ads (which was read successfully) + begin + Name_Buffer (1 .. 10) := "system.ads"; + Name_Len := 10; + N := Name_Find; + S := Load_Source_File (N); - else - System_Source_File_Index := S; - end if; + -- Failed to read system.ads, fatal error - Targparm.Get_Target_Parameters - (System_Text => Source_Text (S), - Source_First => Source_First (S), - Source_Last => Source_Last (S), - Make_Id => Tbuild.Make_Id'Access, - Make_SC => Tbuild.Make_SC'Access, - Set_RND => Tbuild.Set_RND'Access); + if S = No_Source_File then + Write_Line + ("fatal error, run-time library not installed correctly"); + Write_Line ("cannot locate file system.ads"); + raise Unrecoverable_Error; - -- Acquire configuration pragma information from Targparm + -- Read system.ads successfully, remember its source index - Restrict.Restrictions := Targparm.Restrictions_On_Target; - end Targparm_Acquire; + else + System_Source_File_Index := S; + end if; + + Targparm.Get_Target_Parameters + (System_Text => Source_Text (S), + Source_First => Source_First (S), + Source_Last => Source_Last (S), + Make_Id => Tbuild.Make_Id'Access, + Make_SC => Tbuild.Make_SC'Access, + Set_RND => Tbuild.Set_RND'Access); + + -- Acquire configuration pragma information from Targparm + + Restrict.Restrictions := Targparm.Restrictions_On_Target; + end Targparm_Acquire; + end if; -- Perform various adjustments and settings of global switches Adjust_Global_Switches; -- Output copyright notice if full list mode unless we have a list - -- file, in which case we defer this so that it is output in the file + -- file, in which case we defer this so that it is output in the file. if (Verbose_Mode or else (Full_List and then Full_List_File_Name = null)) + + -- Debug flag gnatd7 suppresses this copyright notice + and then not Debug_Flag_7 then Write_Eol; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 3ebaa7f6060..5cc0f630e3a 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -1727,6 +1727,15 @@ package body Sem_Aggr is if Is_Type (E) and then Has_Predicates (E) then Freeze_Before (N, E); + if Has_Dynamic_Predicate_Aspect (E) then + Error_Msg_NE ("subtype& has dynamic predicate," + & "not allowed in aggregate choice", Choice, E); + + elsif not Is_Static_Subtype (E) then + Error_Msg_NE ("non-static subtype& has predicate," + & "not allowed in aggregate choice", Choice, E); + end if; + -- If the subtype has a static predicate, replace the -- original choice with the list of individual values -- covered by the predicate. @@ -1882,6 +1891,14 @@ package body Sem_Aggr is elsif Nkind (Choice) = N_Subtype_Indication then Resolve_Discrete_Subtype_Indication (Choice, Index_Base); + if Has_Dynamic_Predicate_Aspect + (Entity (Subtype_Mark (Choice))) + then + Error_Msg_NE ("subtype& has dynamic predicate, " + & "not allowed in aggregate choice", + Choice, Entity (Subtype_Mark (Choice))); + end if; + -- Does the subtype indication evaluation raise CE? Get_Index_Bounds (Subtype_Mark (Choice), S_Low, S_High); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index df59cb7c63c..560eb03875f 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2920,6 +2920,11 @@ package body Sem_Ch3 is if not Is_Overloaded (E) then T := Etype (E); + if Has_Dynamic_Predicate_Aspect (T) then + Error_Msg_N + ("subtype has dynamic predicate, " + & "not allowed in number declaration", N); + end if; else T := Any_Type; @@ -12424,6 +12429,10 @@ package body Sem_Ch3 is -- The parser has verified that this is a discrete indication Resolve_Discrete_Subtype_Indication (S, T); + Bad_Predicated_Subtype_Use + ("subtype& has predicate, not allowed in index constraint", + S, Entity (Subtype_Mark (S))); + R := Range_Expression (Constraint (S)); -- Capture values of bounds and generate temporaries for them if @@ -16802,6 +16811,7 @@ package body Sem_Ch3 is procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is begin + Set_Has_Predicates (Subt, Has_Predicates (Par)); Set_Has_Static_Predicate_Aspect (Subt, Has_Static_Predicate_Aspect (Par)); Set_Has_Dynamic_Predicate_Aspect @@ -17419,6 +17429,10 @@ package body Sem_Ch3 is Set_Scalar_Range (Def_Id, R); Conditional_Delay (Def_Id, T); + if Nkind (N) = N_Subtype_Indication then + Inherit_Predicate_Flags (Def_Id, Entity (Subtype_Mark (N))); + end if; + -- In the subtype indication case, if the immediate parent of the -- new subtype is non-static, then the subtype we create is non- -- static, even if its bounds are static. diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 4bbd42fab79..37c864638c4 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2134,6 +2134,12 @@ package body Sem_Ch5 is -- to capture the bounds, so that the function result can be finalized -- in timely fashion. + procedure Check_Predicate_Use (T : Entity_Id); + -- Diagnose Attempt to iterate through non-static predicate. Note that + -- a type with inherited predicates may have both static and dynamic + -- forms. In this case it is not sufficent to check the static predicate + -- function only, look for a dynamic predicate aspect as well. + function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean; -- N is the node for an arbitrary construct. This function searches the -- construct N to see if any expressions within it contain function @@ -2192,6 +2198,27 @@ package body Sem_Ch5 is end if; end Check_Controlled_Array_Attribute; + ------------------------- + -- Check_Predicate_Use -- + ------------------------- + + procedure Check_Predicate_Use (T : Entity_Id) is + begin + if Is_Discrete_Type (T) + and then Has_Predicates (T) + and then (not Has_Static_Predicate (T) + or else Has_Dynamic_Predicate_Aspect (T)) + then + Bad_Predicated_Subtype_Use + ("cannot use subtype& with non-static predicate for loop " & + "iteration", Discrete_Subtype_Definition (N), + T, Suggest_Static => True); + + elsif Inside_A_Generic and then Is_Generic_Formal (T) then + Set_No_Dynamic_Predicate_On_Actual (T); + end if; + end Check_Predicate_Use; + ------------------------------------ -- Has_Call_Using_Secondary_Stack -- ------------------------------------ @@ -2566,23 +2593,7 @@ package body Sem_Ch5 is Set_Etype (DS, Entity (DS)); end if; - -- Attempt to iterate through non-static predicate. Note that a type - -- with inherited predicates may have both static and dynamic forms. - -- In this case it is not sufficent to check the static predicate - -- function only, look for a dynamic predicate aspect as well. - - if Is_Discrete_Type (Entity (DS)) - and then Has_Predicates (Entity (DS)) - and then (not Has_Static_Predicate (Entity (DS)) - or else Has_Dynamic_Predicate_Aspect (Entity (DS))) - then - Bad_Predicated_Subtype_Use - ("cannot use subtype& with non-static predicate for loop " & - "iteration", DS, Entity (DS), Suggest_Static => True); - - elsif Inside_A_Generic and then Is_Generic_Formal (Entity (DS)) then - Set_No_Dynamic_Predicate_On_Actual (Entity (DS)); - end if; + Check_Predicate_Use (Entity (DS)); end if; -- Error if not discrete type @@ -2594,6 +2605,10 @@ package body Sem_Ch5 is Check_Controlled_Array_Attribute (DS); + if Nkind (DS) = N_Subtype_Indication then + Check_Predicate_Use (Entity (Subtype_Mark (DS))); + end if; + Make_Index (DS, N, In_Iter_Schm => True); Set_Ekind (Id, E_Loop_Parameter); diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 82fa38a9917..7a49d4bfe20 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -2896,6 +2896,17 @@ package body Sem_Ch9 is begin Check_Restriction (No_Tasking, N); Tasking_Used := True; + + -- The sequential partition elaboration policy is supported only in the + -- restricted profile. + + if Partition_Elaboration_Policy = 'S' + and then not Restricted_Profile + then + Error_Msg_N + ("sequential elaboration supported only in restricted profile", N); + end if; + T := Find_Type_Name (N); Generate_Definition (T); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 38c1017e339..c0d3638313e 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -9814,14 +9814,28 @@ package body Sem_Res is -- Check bad use of type with predicates - if Has_Predicates (Etype (Drange)) then - Bad_Predicated_Subtype_Use - ("subtype& has predicate, not allowed in slice", - Drange, Etype (Drange)); + declare + Subt : Entity_Id; + + begin + if Nkind (Drange) = N_Subtype_Indication + and then Has_Predicates (Entity (Subtype_Mark (Drange))) + then + Subt := Entity (Subtype_Mark (Drange)); + + else + Subt := Etype (Drange); + end if; + + if Has_Predicates (Subt) then + Bad_Predicated_Subtype_Use + ("subtype& has predicate, not allowed in slice", Drange, Subt); + end if; + end; -- Otherwise here is where we check suspicious indexes - elsif Nkind (Drange) = N_Range then + if Nkind (Drange) = N_Range then Warn_On_Suspicious_Index (Name, Low_Bound (Drange)); Warn_On_Suspicious_Index (Name, High_Bound (Drange)); end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 44435ca0812..23c5fa7edb2 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -782,7 +782,15 @@ package body Sem_Util is Suggest_Static : Boolean := False) is Gen : Entity_Id; + begin + + -- Avoid cascaded errors + + if Error_Posted (N) then + return; + end if; + if Inside_A_Generic then Gen := Current_Scope; while Present (Gen) and then Ekind (Gen) /= E_Generic_Package loop