diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 26 | ||||
| -rw-r--r-- | gcc/ada/comperr.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/exp_strm.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/gnat1drv.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/inline.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/par-ch13.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/par-ch3.adb | 21 | ||||
| -rw-r--r-- | gcc/ada/s-taskin.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/s-tassta.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 48 | ||||
| -rw-r--r-- | gcc/ada/sem_elab.adb | 39 |
12 files changed, 152 insertions, 42 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7065302d18b..af1ecf521bc 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,29 @@ +2014-11-20 Robert Dewar <dewar@adacore.com> + + * s-tassta.adb, exp_aggr.adb, s-taskin.adb, exp_strm.adb: Minor + reformatting. + * comperr.adb (Compiler_Abort): New wording for bug box. + * par-ch13.adb: Minor reformatting. + * par-ch3.adb (P_Identifier_Declarations): Handle aspect + specifications given before initialization expression in object + declaration cleanly. + * gnat1drv.adb (Adjust_Global_Switches): Make sure static + elaboration mode is set if we are operating in SPARK mode. + * sem_ch12.adb (Analyze_Package_Instantiation): Make + sure static elab mode is set if we are in SPARK mode. + (Analyze_Subprogram_Instantiation): ditto. + (Set_Instance_Env): ditto. + * sem_elab.adb (Check_A_Call): In SPARK mode, we require + Elaborate_All in the case of a call during elaboration to a + subprogram in another unit. + +2014-11-20 Ed Schonberg <schonberg@adacore.com> + + * inline.adb (Can_Split_Unconstrained_Function, + Build_Procedure): Copy parameter type rather than creating + reference to the entity, to capture class-wide reference, whose + name is not retrieved by visibility. + 2014-11-20 Arnaud Charlet <charlet@adacore.com> * s-taspri-solaris.ads: Replace 64 by long_long_integer'size. diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb index 7a9d7070cde..cabc028417b 100644 --- a/gcc/ada/comperr.adb +++ b/gcc/ada/comperr.adb @@ -367,21 +367,16 @@ package body Comperr is End_Line; Write_Str - ("| Include the exact gcc or gnatmake command " & - "that you entered."); + ("| Include the exact command that you entered."); End_Line; Write_Str - ("| Also include sources listed below in gnatchop format"); - End_Line; - - Write_Str - ("| (concatenated together with no headers between files)."); + ("| Also include sources listed below."); End_Line; if not Is_FSF_Version then Write_Str - ("| Use plain ASCII or MIME attachment."); + ("| Use plain ASCII or MIME attachment(s)."); End_Line; end if; end if; diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index d9a43ff8d28..25c8db34782 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -2125,10 +2125,10 @@ package body Exp_Aggr is Btype := Base_Type (Typ); while Is_Derived_Type (Btype) - and then (Present (Stored_Constraint (Btype)) - or else - (In_Aggr_Type - and then Present (Stored_Constraint (Typ)))) + and then + (Present (Stored_Constraint (Btype)) + or else + (In_Aggr_Type and then Present (Stored_Constraint (Typ)))) loop Parent_Type := Etype (Btype); @@ -2155,7 +2155,7 @@ package body Exp_Aggr is Discr_Val := First_Elmt (Stored_Constraint (Typ)); end if; - while Present (Discr_Val) and Present (Disc) loop + while Present (Discr_Val) and then Present (Disc) loop -- Only those discriminants of the parent that are not -- renamed by discriminants of the derived type need to diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index 210183d8130..1c0713c3d30 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -966,10 +966,10 @@ package body Exp_Strm is Make_Handled_Sequence_Of_Statements (Loc, Statements => Stms)); - -- If Typ has controlled components (i.e. if it is classwide - -- or Has_Controlled), or components constrained using the discriminants - -- of Typ, then we need to ensure that all component assignments - -- are performed on an object that has been appropriately constrained + -- If Typ has controlled components (i.e. if it is classwide or + -- Has_Controlled), or components constrained using the discriminants + -- of Typ, then we need to ensure that all component assignments are + -- performed on an object that has been appropriately constrained -- prior to being initialized. To this effect, we wrap the component -- assignments in a block where V is a constrained temporary. @@ -979,7 +979,7 @@ package body Exp_Strm is Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (Base_Type (Typ), Loc), - Constraint => + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => Cstr)))); diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index cd6b6f48f79..81eb6397e5c 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -368,11 +368,8 @@ procedure Gnat1drv is Suppress_Options.Suppress := (others => False); - -- Turn off dynamic elaboration checks: generates inconsistencies in - -- trees between specs compiled as part of a main unit or as part of - -- a with-clause. - - -- Comment is incomplete, SPARK semantics rely on static mode no??? + -- Turn off dynamic elaboration checks. SPARK mode depends on the + -- use of the static elaboration mode. Dynamic_Elaboration_Checks := False; diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index ca84a1f2268..438be773d7f 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -1736,6 +1736,11 @@ package body Inline is Parameter_Type => Param_Type)); Formal := First_Formal (Spec_Id); + + -- Note that we copy the parameter type rather than creating + -- a reference to it, because it may be a class-wide entity + -- that will not be retrieved by name. + while Present (Formal) loop Append_To (Formal_List, Make_Parameter_Specification (Loc, @@ -1747,7 +1752,7 @@ package body Inline is Null_Exclusion_Present => Null_Exclusion_Present (Parent (Formal)), Parameter_Type => - New_Occurrence_Of (Etype (Formal), Loc), + New_Copy_Tree (Parameter_Type (Parent (Formal))), Expression => Copy_Separate_Tree (Expression (Parent (Formal))))); diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb index 5f448f67543..ba528faf62f 100644 --- a/gcc/ada/par-ch13.adb +++ b/gcc/ada/par-ch13.adb @@ -568,8 +568,7 @@ package body Ch13 is then Scan; -- past identifier - -- Attempt to detect ' or => following a potential aspect - -- mark. + -- Attempt to detect ' or => following potential aspect mark if Token = Tok_Apostrophe or else Token = Tok_Arrow then Restore_Scan_State (Scan_State); @@ -580,14 +579,13 @@ package body Ch13 is end if; end if; - -- The construct following the current aspect is not an - -- aspect. + -- Construct following the current aspect is not an aspect Restore_Scan_State (Scan_State); end; end if; - -- Must be terminator character + -- Require semicolon if caller expects to scan this out if Semicolon then T_Semicolon; diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 7e4dc8f2623..80c95a9c635 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -1858,7 +1858,26 @@ package body Ch3 is end if; Set_Defining_Identifier (Decl_Node, Idents (Ident)); - P_Aspect_Specifications (Decl_Node); + P_Aspect_Specifications (Decl_Node, Semicolon => False); + + -- Allow initialization expression to follow aspects (note that in + -- this case P_Aspect_Specifications already issued an error msg). + + if Token = Tok_Colon_Equal then + if Is_Non_Empty_List (Aspect_Specifications (Decl_Node)) then + Error_Msg + ("aspect specifications must come after initialization " + & "expression", + Sloc (First (Aspect_Specifications (Decl_Node)))); + end if; + + Set_Expression (Decl_Node, Init_Expr_Opt); + Set_Has_Init_Expression (Decl_Node); + end if; + + -- Now scan out the semicolon, which we deferred above + + T_Semicolon; if List_OK then if Ident < Num_Idents then diff --git a/gcc/ada/s-taskin.adb b/gcc/ada/s-taskin.adb index 7ed47697a7b..310873b1288 100644 --- a/gcc/ada/s-taskin.adb +++ b/gcc/ada/s-taskin.adb @@ -110,6 +110,10 @@ package body System.Tasking is return; end if; + -- Note that use of an aggregate here for this assignment + -- would be illegal, because Common_ATCB is limited because + -- Task_Primitives.Private_Data is limited. + T.Common.Parent := Parent; T.Common.Base_Priority := Base_Priority; T.Common.Base_CPU := Base_CPU; diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index 9f9383a2e1d..5353326de45 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -662,6 +662,9 @@ package body System.Tasking.Stages is T.Common.Task_Image_Len := Len; end if; + -- Note: we used to have code here to initialize T.Commmon.Domain, but + -- that is not needed, since this is initialized in System.Tasking. + Unlock (Self_ID); Unlock_RTS; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index d77c1d5e13e..3ded01acf0e 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -4455,6 +4455,10 @@ package body Sem_Ch12 is SPARK_Mode_Pragma := Save_SMP; Style_Check := Save_Style_Check; + if SPARK_Mode = On then + Dynamic_Elaboration_Checks := False; + end if; + -- Check that if N is an instantiation of System.Dim_Float_IO or -- System.Dim_Integer_IO, the formal type has a dimension system. @@ -4491,6 +4495,10 @@ package body Sem_Ch12 is SPARK_Mode := Save_SM; SPARK_Mode_Pragma := Save_SMP; Style_Check := Save_Style_Check; + + if SPARK_Mode = On then + Dynamic_Elaboration_Checks := False; + end if; end Analyze_Package_Instantiation; -------------------------- @@ -5346,6 +5354,11 @@ package body Sem_Ch12 is Ignore_Pragma_SPARK_Mode := Save_IPSM; SPARK_Mode := Save_SM; SPARK_Mode_Pragma := Save_SMP; + + if SPARK_Mode = On then + Dynamic_Elaboration_Checks := False; + end if; + end if; <<Leave>> @@ -5366,6 +5379,10 @@ package body Sem_Ch12 is Ignore_Pragma_SPARK_Mode := Save_IPSM; SPARK_Mode := Save_SM; SPARK_Mode_Pragma := Save_SMP; + + if SPARK_Mode = On then + Dynamic_Elaboration_Checks := False; + end if; end Analyze_Subprogram_Instantiation; ------------------------- @@ -9748,6 +9765,7 @@ package body Sem_Ch12 is Loc : Source_Ptr; Nam : Node_Id; New_Spec : Node_Id; + New_Subp : Entity_Id; -- Start of processing for Instantiate_Formal_Subprogram @@ -9763,10 +9781,10 @@ package body Sem_Ch12 is -- Create new entity for the actual (New_Copy_Tree does not), and -- indicate that it is an actual. - Set_Defining_Unit_Name - (New_Spec, Make_Defining_Identifier (Loc, Chars (Formal_Sub))); - Set_Ekind (Defining_Unit_Name (New_Spec), Ekind (Analyzed_S)); - Set_Is_Generic_Actual_Subprogram (Defining_Unit_Name (New_Spec)); + New_Subp := Make_Defining_Identifier (Loc, Chars (Formal_Sub)); + Set_Ekind (New_Subp, Ekind (Analyzed_S)); + Set_Is_Generic_Actual_Subprogram (New_Subp); + Set_Defining_Unit_Name (New_Spec, New_Subp); -- Create new entities for the each of the formals in the specification -- of the renaming declaration built for the actual. @@ -10208,7 +10226,21 @@ package body Sem_Ch12 is begin Typ := Get_Instance_Of (Formal_Type); - Freeze_Before (Instantiation_Node, Typ); + -- If the actual appears in the current or an enclosing scope, + -- use its type directly. This is relevant if it has an actual + -- subtype that is distinct from its nominal one. This cannot + -- be done in general because the type of the actual may + -- depend on other actuals, and only be fully determined when + -- the enclosing instance is analyzed. + + if Present (Etype (Actual)) + and then Is_Constr_Subt_For_U_Nominal (Etype (Actual)) + then + Freeze_Before (Instantiation_Node, Etype (Actual)); + + else + Freeze_Before (Instantiation_Node, Typ); + end if; -- If the actual is an aggregate, perform name resolution on -- its components (the analysis of an aggregate does not do it) @@ -14424,6 +14456,12 @@ package body Sem_Ch12 is SPARK_Mode := Save_SPARK_Mode; SPARK_Mode_Pragma := Save_SPARK_Mode_Pragma; + + -- Make sure dynamic elaboration checks are off in SPARK Mode + + if SPARK_Mode = On then + Dynamic_Elaboration_Checks := False; + end if; end if; Current_Instantiated_Parent := diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index ad1b0493a96..006e3201a0d 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -915,23 +915,31 @@ package body Sem_Elab is and then not Elaboration_Checks_Suppressed (Ent) and then not Suppress_Elaboration_Warnings (E_Scope) and then not Elaboration_Checks_Suppressed (E_Scope) - and then (Elab_Warnings or Elab_Info_Messages) + and then ((Elab_Warnings or Elab_Info_Messages) + or else SPARK_Mode = On) and then Generate_Warnings then -- Instantiation case if Inst_Case then - Elab_Warning - ("instantiation of& may raise Program_Error?l?", - "info: instantiation of& during elaboration?$?", Ent); + if SPARK_Mode = On then + Error_Msg_NE + ("instantiation of & during elaboration in SPARK mode", + N, Ent); + + else + Elab_Warning + ("instantiation of & may raise Program_Error?l?", + "info: instantiation of & during elaboration?$?", Ent); + end if; -- Indirect call case, info message only in static elaboration -- case, because the attribute reference itself cannot raise an - -- exception. + -- exception. Note that SPARK does not permit indirect calls. elsif Access_Case then Elab_Warning - ("", "info: access to& during elaboration?$?", Ent); + ("", "info: access to & during elaboration?$?", Ent); -- Subprogram call case @@ -945,6 +953,10 @@ package body Sem_Elab is "info: implicit call to & during elaboration?$?", Ent); + elsif SPARK_Mode = On then + Error_Msg_NE + ("call to & during elaboration in SPARK mode", N, Ent); + else Elab_Warning ("call to & may raise Program_Error?l?", @@ -955,12 +967,25 @@ package body Sem_Elab is Error_Msg_Qual_Level := Nat'Last; - if Nkind (N) in N_Subprogram_Instantiation then + -- Case of Elaborate_All not present and required, for SPARK this + -- is an error, so give an error message. + + if SPARK_Mode = On then + Error_Msg_NE + ("\Elaborate_All pragma required for&", N, W_Scope); + + -- Otherwise we generate an implicit pragma. For a subprogram + -- instantiation, Elaborate is good enough, since no transitive + -- call is possible at elaboration time in this case. + + elsif Nkind (N) in N_Subprogram_Instantiation then Elab_Warning ("\missing pragma Elaborate for&?l?", "\implicit pragma Elaborate for& generated?$?", W_Scope); + -- For all other cases, we need an implicit Elaborate_All + else Elab_Warning ("\missing pragma Elaborate_All for&?l?", |