From f9adb9d4809ee3a581551734f9d82a03ce5cff18 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 2 Aug 2011 17:30:55 +0200 Subject: [PATCH] [multiple changes] 2011-08-02 Vincent Celier * link.c: Only import "auto-host.h" when building the gnattools. 2011-08-02 Yannick Moy * sem_util.adb: Inter-unit inlining does not work for a subprogram which calls a local subprogram, so extract subprogram from Mark_Non_ALFA_Subprogram_Body. 2011-08-02 Javier Miranda * exp_ch9.adb (Extract_Dispatching_Call): If the type of the dispatching object is an access type then return an explicit dereference in the Object out-mode parameter. 2011-08-02 Gary Dismukes * sem_ch3.adb (Analyze_Subtype_Declaration): Generate range compatibility checks for all indexes of an array subtype, not just the first. Reset Has_Dynamic_Range_Check on the subtype before each potential check to ensure that Insert_Range_Checks will not elide any of the dynamic checks. 2011-08-02 Yannick Moy * par-prag.ad (Process_Restrictions_Or_Restriction_Warnings): recognize SPARK restriction at parsing time. * scng.adb (Scan): Generate a token Tok_SPARK_Hide for a SPARK HIDE directive only if the SPARK restriction is set for this unit. From-SVN: r177183 --- gcc/ada/ChangeLog | 32 ++++++++++++++++ gcc/ada/exp_ch9.adb | 14 ++++++- gcc/ada/link.c | 3 ++ gcc/ada/par-prag.adb | 18 ++++++--- gcc/ada/scng.adb | 9 ++++- gcc/ada/sem_ch3.adb | 89 +++++++++++++++++++++++++++++--------------- gcc/ada/sem_util.adb | 38 ++++++++++--------- 7 files changed, 147 insertions(+), 56 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 99cf2c347e1..cabcec110d3 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,35 @@ +2011-08-02 Vincent Celier + + * link.c: Only import "auto-host.h" when building the gnattools. + +2011-08-02 Yannick Moy + + * sem_util.adb: Inter-unit inlining does not work for a subprogram + which calls a local subprogram, so extract subprogram + from Mark_Non_ALFA_Subprogram_Body. + +2011-08-02 Javier Miranda + + * exp_ch9.adb + (Extract_Dispatching_Call): If the type of the dispatching object is an + access type then return an explicit dereference in the Object out-mode + parameter. + +2011-08-02 Gary Dismukes + + * sem_ch3.adb (Analyze_Subtype_Declaration): Generate range + compatibility checks for all indexes of an array subtype, not just the + first. Reset Has_Dynamic_Range_Check on the subtype before each + potential check to ensure that Insert_Range_Checks will not elide any + of the dynamic checks. + +2011-08-02 Yannick Moy + + * par-prag.ad (Process_Restrictions_Or_Restriction_Warnings): recognize + SPARK restriction at parsing time. + * scng.adb (Scan): Generate a token Tok_SPARK_Hide for a SPARK HIDE + directive only if the SPARK restriction is set for this unit. + 2011-08-02 Yannick Moy * sem_ch3.adb, sem_ch5.adb, sem_ch9.adb, sem_util.adb, sem_util.ads, diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index b8a89bcb55f..ae92522f874 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -341,8 +341,10 @@ package body Exp_Ch9 is Actuals : out List_Id; Formals : out List_Id); -- Given a dispatching call, extract the entity of the name of the call, - -- its object parameter, its actual parameters and the formal parameters - -- of the overridden interface-level version. + -- its actual dispatching object, its actual parameters and the formal + -- parameters of the overridden interface-level version. If the type of + -- the dispatching object is an access type then an explicit dereference + -- is returned in Object. procedure Extract_Entry (N : Node_Id; @@ -11512,6 +11514,14 @@ package body Exp_Ch9 is if Present (Original_Node (Object)) then Object := Original_Node (Object); end if; + + -- If the type of the dispatching object is an access type then return + -- an explicit dereference + + if Is_Access_Type (Etype (Object)) then + Object := Make_Explicit_Dereference (Sloc (N), Object); + Analyze (Object); + end if; end Extract_Dispatching_Call; ------------------- diff --git a/gcc/ada/link.c b/gcc/ada/link.c index 3c21c975e8e..b8fd835c2d8 100644 --- a/gcc/ada/link.c +++ b/gcc/ada/link.c @@ -37,7 +37,10 @@ extern "C" { #endif #include + +#ifdef IN_GCC #include "auto-host.h" +#endif /* objlist_file_supported is set to 1 when the system linker allows */ /* response file, that is a file that contains the list of object files. */ diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index b3dab608a32..6b5318f3385 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -89,11 +89,13 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is procedure Process_Restrictions_Or_Restriction_Warnings; -- Common processing for Restrictions and Restriction_Warnings pragmas. - -- This routine only processes the case of No_Obsolescent_Features, which - -- is the only restriction that has syntactic effects. No general error - -- checking is done, since this will be done in Sem_Prag. The other case - -- processed is pragma Restrictions No_Dependence, since otherwise this is - -- done too late. + -- This routine processes the cases of No_Obsolescent_Features and SPARK, + -- which are the only restriction that have syntactic effects. In the case + -- of SPARK, it controls whether the scanner generates a token + -- Tok_SPARK_Hide for HIDE directives formatted as Ada comments. No general + -- error checking is done, since this will be done in Sem_Prag. The other + -- case processed is pragma Restrictions No_Dependence, since otherwise + -- this is done too late. ---------- -- Arg1 -- @@ -230,6 +232,10 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is Set_Restriction (No_Obsolescent_Features, Pragma_Node); Restriction_Warnings (No_Obsolescent_Features) := Prag_Id = Pragma_Restriction_Warnings; + when SPARK => + Set_Restriction (SPARK, Pragma_Node); + Restriction_Warnings (SPARK) := + Prag_Id = Pragma_Restriction_Warnings; when others => null; end case; diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index 420a4f0f037..73b8f393dca 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -28,6 +28,8 @@ with Err_Vars; use Err_Vars; with Hostparm; use Hostparm; with Namet; use Namet; with Opt; use Opt; +with Restrict; use Restrict; +with Rident; use Rident; with Scans; use Scans; with Sinput; use Sinput; with Snames; use Snames; @@ -1762,7 +1764,12 @@ package body Scng is return; end if; - if Source (Start_Of_Comment) = '#' then + -- Generate a token Tok_SPARK_Hide for a SPARK HIDE directive + -- only if the SPARK restriction is set for this unit. + + if Restriction_Check_Required (SPARK) + and then Source (Start_Of_Comment) = '#' + then declare Scan_SPARK_Ptr : Source_Ptr; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index dfde2ed07a4..2f5bb0244c8 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4396,9 +4396,9 @@ package body Sem_Ch3 is Conditional_Delay (Id, T); end if; - -- Check that constraint_error is raised for a scalar subtype - -- indication when the lower or upper bound of a non-null range - -- lies outside the range of the type mark. + -- Check that Constraint_Error is raised for a scalar subtype indication + -- when the lower or upper bound of a non-null range lies outside the + -- range of the type mark. if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then if Is_Scalar_Type (Etype (Id)) @@ -4410,38 +4410,69 @@ package body Sem_Ch3 is (Scalar_Range (Id), Etype (Subtype_Mark (Subtype_Indication (N)))); + -- In the array case, check compatibility for each index + elsif Is_Array_Type (Etype (Id)) and then Present (First_Index (Id)) then -- This really should be a subprogram that finds the indications -- to check??? - if ((Nkind (First_Index (Id)) = N_Identifier - and then Ekind (Entity (First_Index (Id))) in Scalar_Kind) - or else Nkind (First_Index (Id)) = N_Subtype_Indication) - and then - Nkind (Scalar_Range (Etype (First_Index (Id)))) = N_Range - then - declare - Target_Typ : constant Entity_Id := - Etype - (First_Index (Etype - (Subtype_Mark (Subtype_Indication (N))))); - begin - R_Checks := - Get_Range_Checks - (Scalar_Range (Etype (First_Index (Id))), - Target_Typ, - Etype (First_Index (Id)), - Defining_Identifier (N)); - - Insert_Range_Checks - (R_Checks, - N, - Target_Typ, - Sloc (Defining_Identifier (N))); - end; - end if; + declare + Subt_Index : Node_Id := First_Index (Id); + Target_Index : Node_Id := + First_Index (Etype + (Subtype_Mark (Subtype_Indication (N)))); + Has_Dyn_Chk : Boolean := Has_Dynamic_Range_Check (N); + + begin + while Present (Subt_Index) loop + if ((Nkind (Subt_Index) = N_Identifier + and then Ekind (Entity (Subt_Index)) in Scalar_Kind) + or else Nkind (Subt_Index) = N_Subtype_Indication) + and then + Nkind (Scalar_Range (Etype (Subt_Index))) = N_Range + then + declare + Target_Typ : constant Entity_Id := + Etype (Target_Index); + begin + R_Checks := + Get_Range_Checks + (Scalar_Range (Etype (Subt_Index)), + Target_Typ, + Etype (Subt_Index), + Defining_Identifier (N)); + + -- Reset Has_Dynamic_Range_Check on the subtype to + -- prevent elision of the index check due to a dynamic + -- check generated for a preceding index (needed since + -- Insert_Range_Checks tries to avoid generating + -- redundant checks on a given declaration). + + Set_Has_Dynamic_Range_Check (N, False); + + Insert_Range_Checks + (R_Checks, + N, + Target_Typ, + Sloc (Defining_Identifier (N))); + + -- Record whether this index involved a dynamic check + + Has_Dyn_Chk := + Has_Dyn_Chk or else Has_Dynamic_Range_Check (N); + end; + end if; + + Next_Index (Subt_Index); + Next_Index (Target_Index); + end loop; + + -- Finally, mark whether the subtype involves dynamic checks + + Set_Has_Dynamic_Range_Check (N, Has_Dyn_Chk); + end; end if; end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index f6fa724e570..397784676de 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -141,6 +141,10 @@ package body Sem_Util is -- T is a derived tagged type. Check whether the type extension is null. -- If the parent type is fully initialized, T can be treated as such. + procedure Mark_Non_ALFA_Subprogram_Body_Unconditional; + -- Perform the action for Mark_Non_ALFA_Subprogram_Body, which allows the + -- latter to be small and inlined. + ------------------------------ -- Abstract_Interface_List -- ------------------------------ @@ -2316,31 +2320,29 @@ package body Sem_Util is ----------------------------------- procedure Mark_Non_ALFA_Subprogram_Body is - - procedure Unconditional_Mark; + begin -- Isolate marking of the current subprogram body so that the body of -- Mark_Non_ALFA_Subprogram_Body is small and inlined. - ------------------------ - -- Unconditional_Mark -- - ------------------------ + if ALFA_Mode then + Mark_Non_ALFA_Subprogram_Body_Unconditional; + end if; + end Mark_Non_ALFA_Subprogram_Body; - procedure Unconditional_Mark is - Cur_Subp : constant Entity_Id := Current_Subprogram; - begin - if Present (Cur_Subp) - and then (Is_Subprogram (Cur_Subp) - or else Is_Generic_Subprogram (Cur_Subp)) - then - Set_Body_Is_In_ALFA (Cur_Subp, False); - end if; - end Unconditional_Mark; + ------------------------------------------------- + -- Mark_Non_ALFA_Subprogram_Body_Unconditional -- + ------------------------------------------------- + procedure Mark_Non_ALFA_Subprogram_Body_Unconditional is + Cur_Subp : constant Entity_Id := Current_Subprogram; begin - if ALFA_Mode then - Unconditional_Mark; + if Present (Cur_Subp) + and then (Is_Subprogram (Cur_Subp) + or else Is_Generic_Subprogram (Cur_Subp)) + then + Set_Body_Is_In_ALFA (Cur_Subp, False); end if; - end Mark_Non_ALFA_Subprogram_Body; + end Mark_Non_ALFA_Subprogram_Body_Unconditional; --------------------- -- Defining_Entity -- -- 2.30.2