diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 21 | ||||
| -rw-r--r-- | gcc/ada/errout.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-elchha.adb | 26 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 71 | ||||
| -rw-r--r-- | gcc/ada/sem_elab.adb | 21 |
5 files changed, 127 insertions, 14 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 58291de..9306265 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,24 @@ +2017-11-16 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_elab.adb (Include): Including a node which is also a compilation + unit terminates the search because there are no more lists to examine. + +2017-11-16 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch8.adb (Analyze_Subprogram_Renaming): Ensure that a renaming + declaration does not define a primitive operation of a tagged type for + SPARK. + (Check_SPARK_Primitive_Operation): New routine. + +2017-11-16 Arnaud Charlet <charlet@adacore.com> + + * libgnat/a-elchha.adb (Last_Chance_Handler): Display Argv (0) in + message when using -E binder switch. + +2017-11-16 Piotr Trojanek <trojanek@adacore.com> + + * errout.ads: Fix minor typo in comment. + 2017-11-16 Ed Schonberg <schonberg@adacore.com> * sem_ch3.adb (Process_Subtype): If the subtype indication does not diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index d3de0ad..1d8b8fc 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -218,7 +218,7 @@ package Errout is -- Insertion character } (Right brace: insert type reference) -- The character } is replaced by a string describing the type -- referenced by the entity whose Id is stored in Error_Msg_Node_1. - -- the string gives the name or description of the type, and also + -- The string gives the name or description of the type, and also -- where appropriate the location of its declaration. Special cases -- like "some integer type" are handled appropriately. Only one } is -- allowed in a message, since there is not enough room for two (the diff --git a/gcc/ada/libgnat/a-elchha.adb b/gcc/ada/libgnat/a-elchha.adb index 8839e8f..0d612c2 100644 --- a/gcc/ada/libgnat/a-elchha.adb +++ b/gcc/ada/libgnat/a-elchha.adb @@ -34,7 +34,7 @@ pragma Compiler_Unit_Warning; with System.Standard_Library; use System.Standard_Library; -with System.Soft_Links; +with System.Soft_Links; use System; procedure Ada.Exceptions.Last_Chance_Handler (Except : Exception_Occurrence) @@ -67,6 +67,15 @@ is pragma Import (Ada, To_Stderr, "__gnat_to_stderr"); -- Little routine to output string to stderr + Gnat_Argv : System.Address; + pragma Import (C, Gnat_Argv, "gnat_argv"); + + procedure Fill_Arg (A : System.Address; Arg_Num : Integer); + pragma Import (C, Fill_Arg, "__gnat_fill_arg"); + + function Len_Arg (Arg_Num : Integer) return Integer; + pragma Import (C, Len_Arg, "__gnat_len_arg"); + Ptr : Natural := 0; Nobuf : String (1 .. 0); @@ -131,7 +140,20 @@ begin else To_Stderr (Nline); - To_Stderr ("Execution terminated by unhandled exception"); + + if Gnat_Argv = System.Null_Address then + To_Stderr ("Execution terminated by unhandled exception"); + else + declare + Arg : aliased String (1 .. Len_Arg (0)); + begin + Fill_Arg (Arg'Address, 0); + To_Stderr ("Execution of "); + To_Stderr (Arg); + To_Stderr (" terminated by unhandled exception"); + end; + end if; + To_Stderr (Nline); Append_Info_Untailored_Exception_Information (Except, Nobuf, Ptr); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index d8d5b7b..729e717 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -59,6 +59,7 @@ with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; +with Sem_Prag; use Sem_Prag; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sem_Type; use Sem_Type; @@ -1924,6 +1925,10 @@ package body Sem_Ch8 is -- have one. Otherwise the subtype of Sub's return profile must -- exclude null. + procedure Check_SPARK_Primitive_Operation (Subp_Id : Entity_Id); + -- Ensure that a SPARK renaming denoted by its entity Subp_Id does not + -- declare a primitive operation of a tagged type (SPARK RM 6.1.1(3)). + procedure Freeze_Actual_Profile; -- In Ada 2012, enforce the freezing rule concerning formal incomplete -- types: a callable entity freezes its profile, unless it has an @@ -2519,6 +2524,52 @@ package body Sem_Ch8 is end if; end Check_Null_Exclusion; + ------------------------------------- + -- Check_SPARK_Primitive_Operation -- + ------------------------------------- + + procedure Check_SPARK_Primitive_Operation (Subp_Id : Entity_Id) is + Prag : constant Node_Id := SPARK_Pragma (Subp_Id); + Typ : Entity_Id; + + begin + -- Nothing to do when the subprogram appears within an instance + + if In_Instance then + return; + + -- Nothing to do when the subprogram is not subject to SPARK_Mode On + -- because this check applies to SPARK code only. + + elsif not (Present (Prag) + and then Get_SPARK_Mode_From_Annotation (Prag) = On) + then + return; + + -- Nothing to do when the subprogram is not a primitive operation + + elsif not Is_Primitive (Subp_Id) then + return; + end if; + + Typ := Find_Dispatching_Type (Subp_Id); + + -- Nothing to do when the subprogram is a primitive operation of an + -- untagged type. + + if No (Typ) then + return; + end if; + + -- At this point a renaming declaration introduces a new primitive + -- operation for a tagged type. + + Error_Msg_Node_2 := Typ; + Error_Msg_NE + ("subprogram renaming & cannot declare primitive for type & " + & "(SPARK RM 6.1.1(3))", N, Subp_Id); + end Check_SPARK_Primitive_Operation; + --------------------------- -- Freeze_Actual_Profile -- --------------------------- @@ -2899,7 +2950,7 @@ package body Sem_Ch8 is -- Set SPARK mode from current context - Set_SPARK_Pragma (New_S, SPARK_Mode_Pragma); + Set_SPARK_Pragma (New_S, SPARK_Mode_Pragma); Set_SPARK_Pragma_Inherited (New_S); Rename_Spec := Find_Corresponding_Spec (N); @@ -3009,13 +3060,16 @@ package body Sem_Ch8 is Generate_Definition (New_S); New_Overloaded_Entity (New_S); - if Is_Entity_Name (Nam) - and then Is_Intrinsic_Subprogram (Entity (Nam)) + if not (Is_Entity_Name (Nam) + and then Is_Intrinsic_Subprogram (Entity (Nam))) then - null; - else Check_Delayed_Subprogram (New_S); end if; + + -- Verify that a SPARK renaming does not declare a primitive + -- operation of a tagged type. + + Check_SPARK_Primitive_Operation (New_S); end if; -- There is no need for elaboration checks on the new entity, which may @@ -3205,10 +3259,9 @@ package body Sem_Ch8 is elsif Requires_Overriding (Old_S) or else - (Is_Abstract_Subprogram (Old_S) - and then Present (Find_Dispatching_Type (Old_S)) - and then - not Is_Abstract_Type (Find_Dispatching_Type (Old_S))) + (Is_Abstract_Subprogram (Old_S) + and then Present (Find_Dispatching_Type (Old_S)) + and then not Is_Abstract_Type (Find_Dispatching_Type (Old_S))) then Error_Msg_N ("renamed entity cannot be subprogram that requires overriding " diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 1217a2c..b66eae4 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -4245,7 +4245,7 @@ package body Sem_Elab is procedure Include (N : Node_Id; Curr : in out Node_Id); pragma Inline (Include); -- Update the Curr and Start pointers to include arbitrary construct N - -- in the early call region. + -- in the early call region. This routine raises ECR_Found. function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean; pragma Inline (Is_OK_Preelaborable_Construct); @@ -4559,7 +4559,24 @@ package body Sem_Elab is procedure Include (N : Node_Id; Curr : in out Node_Id) is begin Start := N; - Curr := Prev (Start); + + -- The input node is a compilation unit. This terminates the search + -- because there are no more lists to inspect and there are no more + -- enclosing constructs to climb up to. The transitions are: + -- + -- private declarations -> terminate + -- visible declarations -> terminate + -- statements -> terminate + -- declarations -> terminate + + if Nkind (Parent (Start)) = N_Compilation_Unit then + raise ECR_Found; + + -- Otherwise the input node is still within some list + + else + Curr := Prev (Start); + end if; end Include; ----------------------------------- |