From aff557c74c4bff664d8b65d68444a5e2b57bd048 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 12 Nov 2015 14:25:40 +0100 Subject: [PATCH] [multiple changes] 2015-11-12 Bob Duff * impunit.adb, lib-xref.ads, restrict.ads, scos.ads, sem_attr.ads, types.ads: Get rid of some global variables. * output.adb, output.ads: Move some global variables to the body. 2015-11-12 Yannick Moy * lib-xref-spark_specific.adb (Is_Constant_Object_Without_Variable_Input): Add special case for imported constants. 2015-11-12 Philippe Gil * g-debpoo.adb (Allocate): Avoid having allocations not handled. 2015-11-12 Ed Schonberg * checks.adb (Apply_Scalar_Range_Check): If the expression is a real literal and the context type has static bounds, remove range check when possible. 2015-11-12 Ed Schonberg * sem_util.adb (Collect_Primitive_Operations): If the type is derived from a type declared elsewhere that has an incomplete type declaration, the primitives are found in the scope of the type nat that of its ancestor. 2015-11-12 Arnaud Charlet * switch-c.adb, debug.adb, osint-c.adb, gnat1drv.adb: Remove -gnatd.V debug switch. * exp_aggr.adb, exp_util.adb: Fix typos. 2015-11-12 Jerome Lambourg * init.c: Properly adjust PC values in case of signals. 2015-11-12 Bob Duff * sem_prag.adb (Check_Arg_Is_Library_Level_Local_Name): A pragma that comes from an aspect does not "come from source", so we need to test whether it comes from an aspect. From-SVN: r230253 --- gcc/ada/ChangeLog | 45 +++++++++++++++++++++++++++++ gcc/ada/checks.adb | 26 ++++++++++++++++- gcc/ada/exp_aggr.adb | 3 +- gcc/ada/exp_util.adb | 45 +++++++++++++---------------- gcc/ada/g-debpoo.adb | 9 ++++-- gcc/ada/gnat1drv.adb | 8 +---- gcc/ada/impunit.adb | 22 +++++++------- gcc/ada/init.c | 39 +++++++++++++++++++++++++ gcc/ada/lib-xref-spark_specific.adb | 8 +++-- gcc/ada/lib-xref.ads | 2 +- gcc/ada/osint-c.adb | 5 +++- gcc/ada/output.adb | 11 +++++++ gcc/ada/output.ads | 14 --------- gcc/ada/restrict.ads | 2 +- gcc/ada/scos.ads | 5 ++-- gcc/ada/sem_attr.ads | 3 +- gcc/ada/sem_prag.adb | 6 +++- gcc/ada/sem_util.adb | 8 +++++ gcc/ada/switch-c.adb | 9 ------ gcc/ada/types.ads | 7 +++-- 20 files changed, 193 insertions(+), 84 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 51448ed271f..98764271489 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,48 @@ +2015-11-12 Bob Duff + + * impunit.adb, lib-xref.ads, restrict.ads, scos.ads, sem_attr.ads, + types.ads: Get rid of some global variables. + * output.adb, output.ads: Move some global variables to the body. + +2015-11-12 Yannick Moy + + * lib-xref-spark_specific.adb + (Is_Constant_Object_Without_Variable_Input): Add special case + for imported constants. + +2015-11-12 Philippe Gil + + * g-debpoo.adb (Allocate): Avoid having allocations not handled. + +2015-11-12 Ed Schonberg + + * checks.adb (Apply_Scalar_Range_Check): If the expression is + a real literal and the context type has static bounds, remove + range check when possible. + +2015-11-12 Ed Schonberg + + * sem_util.adb (Collect_Primitive_Operations): If the type is + derived from a type declared elsewhere that has an incomplete + type declaration, the primitives are found in the scope of the + type nat that of its ancestor. + +2015-11-12 Arnaud Charlet + + * switch-c.adb, debug.adb, osint-c.adb, gnat1drv.adb: Remove -gnatd.V + debug switch. + * exp_aggr.adb, exp_util.adb: Fix typos. + +2015-11-12 Jerome Lambourg + + * init.c: Properly adjust PC values in case of signals. + +2015-11-12 Bob Duff + + * sem_prag.adb (Check_Arg_Is_Library_Level_Local_Name): A + pragma that comes from an aspect does not "come from source", + so we need to test whether it comes from an aspect. + 2015-11-12 Arnaud Charlet * switch-c.adb, gnat1drv.adb, opt.ads: Reserve -gnateg for generation diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 05ec983dee7..b5086cc38d3 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -2878,11 +2878,35 @@ package body Checks is -- Always do a range check if the source type includes infinities and -- the target type does not include infinities. We do not do this if -- range checks are killed. + -- If the expression is a literal and the bounds of the type are + -- static constants it may be possible to optimize the check. if Has_Infinities (S_Typ) and then not Has_Infinities (Target_Typ) then - Enable_Range_Check (Expr); + -- If the expression is a literal and the bounds of the type are + -- static constants it may be possible to optimize the check. + + if Nkind (Expr) = N_Real_Literal then + declare + Tlo : constant Node_Id := Type_Low_Bound (Target_Typ); + Thi : constant Node_Id := Type_High_Bound (Target_Typ); + + begin + if Compile_Time_Known_Value (Tlo) + and then Compile_Time_Known_Value (Thi) + and then Expr_Value_R (Expr) >= Expr_Value_R (Tlo) + and then Expr_Value_R (Expr) <= Expr_Value_R (Thi) + then + return; + else + Enable_Range_Check (Expr); + end if; + end; + + else + Enable_Range_Check (Expr); + end if; end if; end if; diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index dbc0d7afdf3..ad23a661b64 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -1936,8 +1936,7 @@ package body Exp_Aggr is -- constraint associated with the type entity (which is -- preferable, but it's not always present ???) - if Is_Empty_Elmt_List ( - Discriminant_Constraint (Current_Typ)) + if Is_Empty_Elmt_List (Discriminant_Constraint (Current_Typ)) then Assoc := Get_Constraint_Association (Current_Typ); Assoc_Elmt := No_Elmt; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index f2d7b59b18a..bd7b25ce54e 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1672,17 +1672,10 @@ package body Exp_Util is function Containing_Package_With_Ext_Axioms (E : Entity_Id) return Entity_Id is + First_Ax_Parent_Scope : Entity_Id; Decl : Node_Id; begin - if Ekind (E) = E_Package then - if Nkind (Parent (E)) = N_Defining_Program_Unit_Name then - Decl := Parent (Parent (E)); - else - Decl := Parent (E); - end if; - end if; - -- E is the package or generic package which is externally axiomatized if Ekind_In (E, E_Package, E_Generic_Package) @@ -1691,33 +1684,35 @@ package body Exp_Util is return E; end if; - -- If E's scope is axiomatized, E is axiomatized. - - declare - First_Ax_Parent_Scope : Entity_Id := Empty; + -- If E's scope is axiomatized, E is axiomatized - begin - if Present (Scope (E)) then - First_Ax_Parent_Scope := - Containing_Package_With_Ext_Axioms (Scope (E)); - end if; + if Present (Scope (E)) then + First_Ax_Parent_Scope := + Containing_Package_With_Ext_Axioms (Scope (E)); if Present (First_Ax_Parent_Scope) then return First_Ax_Parent_Scope; end if; - -- otherwise, if E is a package instance, it is axiomatized if the - -- corresponding generic package is axiomatized. + end if; + + -- Otherwise, if E is a package instance, it is axiomatized if the + -- corresponding generic package is axiomatized. - if Ekind (E) = E_Package - and then Present (Generic_Parent (Decl)) - then + if Ekind (E) = E_Package then + if Nkind (Parent (E)) = N_Defining_Program_Unit_Name then + Decl := Parent (Parent (E)); + else + Decl := Parent (E); + end if; + + if Present (Generic_Parent (Decl)) then return Containing_Package_With_Ext_Axioms (Generic_Parent (Decl)); - else - return Empty; end if; - end; + end if; + + return Empty; end Containing_Package_With_Ext_Axioms; ------------------------------- diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb index 5857094ff2b..d51ae903c2b 100644 --- a/gcc/ada/g-debpoo.adb +++ b/gcc/ada/g-debpoo.adb @@ -874,7 +874,7 @@ package body GNAT.Debug_Pools is P : Ptr; Trace : Traceback_Htable_Elem_Ptr; - Disable_Exit_Value : constant Boolean := Disable; + Reset_Disable_At_Exit : Boolean := False; begin <> @@ -887,6 +887,7 @@ package body GNAT.Debug_Pools is return; end if; + Reset_Disable_At_Exit := True; Disable := True; Pool.Alloc_Count := Pool.Alloc_Count + 1; @@ -1017,13 +1018,15 @@ package body GNAT.Debug_Pools is Pool.High_Water := Current; end if; - Disable := Disable_Exit_Value; + Disable := False; Unlock_Task.all; exception when others => - Disable := Disable_Exit_Value; + if Reset_Disable_At_Exit then + Disable := False; + end if; Unlock_Task.all; raise; end Allocate; diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 7e5b0671685..17e7d9c5a53 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -142,12 +142,6 @@ procedure Gnat1drv is Modify_Tree_For_C := True; end if; - -- -gnatd.V enables C generation - - if Debug_Flag_Dot_VV then - Generate_C_Code := True; - end if; - -- Set all flags required when generating C code if Generate_C_Code then @@ -222,7 +216,7 @@ procedure Gnat1drv is -- do not expect this to happen in normal use, since both modes are -- enabled by special tools, but it is useful to turn off these flags -- this way when we are doing CodePeer tests on existing test suites - -- that may have -gnatd.V set, to avoid the need for special casing. + -- that may have -gnateg set, to avoid the need for special casing. Modify_Tree_For_C := False; Generate_C_Code := False; diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 5fea99d59c9..e7d86d2faa5 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -604,21 +604,21 @@ package body Impunit is type Aunit_Record is record Fname : String (1 .. 6); - Aname : String_Ptr; + Aname : String_Ptr_Const; end record; -- Array of alternative unit names - Scasuti : aliased String := "GNAT.Case_Util"; - Scrc32 : aliased String := "GNAT.CRC32"; - Shtable : aliased String := "GNAT.HTable"; - Sos_lib : aliased String := "GNAT.OS_Lib"; - Sregexp : aliased String := "GNAT.Regexp"; - Sregpat : aliased String := "GNAT.Regpat"; - Sstring : aliased String := "GNAT.Strings"; - Sstusta : aliased String := "GNAT.Task_Stack_Usage"; - Stasloc : aliased String := "GNAT.Task_Lock"; - Sutf_32 : aliased String := "GNAT.UTF_32"; + Scasuti : aliased constant String := "GNAT.Case_Util"; + Scrc32 : aliased constant String := "GNAT.CRC32"; + Shtable : aliased constant String := "GNAT.HTable"; + Sos_lib : aliased constant String := "GNAT.OS_Lib"; + Sregexp : aliased constant String := "GNAT.Regexp"; + Sregpat : aliased constant String := "GNAT.Regpat"; + Sstring : aliased constant String := "GNAT.Strings"; + Sstusta : aliased constant String := "GNAT.Task_Stack_Usage"; + Stasloc : aliased constant String := "GNAT.Task_Lock"; + Sutf_32 : aliased constant String := "GNAT.UTF_32"; -- Array giving mapping diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 59fc335b6fe..4acf1a29015 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -1911,6 +1911,41 @@ __gnat_vxsim_error_handler (int sig, siginfo_t *si, void *sc); static int is_vxsim = 0; #endif +#if defined (ARMEL) && (_WRS_VXWORKS_MAJOR >= 7) + +/* ARM-vx7 case with arm unwinding exceptions */ +#define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE + +#include +#ifndef __RTP__ +#include +#else +#include +#include +#include +#endif /* __RTP__ */ + +void +__gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, + void *sc ATTRIBUTE_UNUSED) +{ + /* In case of ARM exceptions, the registers context have the PC pointing + to the instruction that raised the signal. However the Unwinder expects + the instruction to be in the range ]PC,PC+1]. + */ + uintptr_t *pc_addr; /* address of the pc value to restore */ +#ifdef __RTP__ + mcontext_t *mcontext = &((ucontext_t *) sc)->uc_mcontext; + pc_addr = (uintptr_t*)&mcontext->regs.pc; +#else + struct sigcontext * sctx = (struct sigcontext *) sc; + pc_addr = (uintptr_t*)&sctx->sc_pregs->pc; +#endif + /* ARM Bump has to be an even number because of odd/even architecture. */ + *pc_addr += 2; +} +#endif /* ARMEL && _WRS_VXWORKS_MAJOR >= 7 */ + /* Tasking and Non-tasking signal handler. Map SIGnal to Ada exception propagation after the required low level adjustments. */ @@ -1958,6 +1993,10 @@ __gnat_error_handler (int sig, siginfo_t *si, void *sc) __gnat_vxsim_error_handler (sig, si, sc); #endif +#ifdef HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE + __gnat_adjust_context_for_raise (sig, sc); +#endif + #include "sigtramp.h" __gnat_sigtramp (sig, (void *)si, (void *)sc, diff --git a/gcc/ada/lib-xref-spark_specific.adb b/gcc/ada/lib-xref-spark_specific.adb index 3280d184a15..43a023747e5 100644 --- a/gcc/ada/lib-xref-spark_specific.adb +++ b/gcc/ada/lib-xref-spark_specific.adb @@ -445,8 +445,12 @@ package body SPARK_Specific is Decl := Parent (E); end if; - pragma Assert (Present (Expression (Decl))); - Result := Is_Static_Expression (Expression (Decl)); + if Is_Imported (E) then + Result := False; + else + pragma Assert (Present (Expression (Decl))); + Result := Is_Static_Expression (Expression (Decl)); + end if; end; when E_Loop_Parameter | E_In_Parameter => diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads index 63d78c7c169..33e20ee2ae2 100644 --- a/gcc/ada/lib-xref.ads +++ b/gcc/ada/lib-xref.ads @@ -433,7 +433,7 @@ package Lib.Xref is -- indicating procedures and functions. If the operation is abstract, -- these letters are replaced in the xref by 'x' and 'y' respectively. - Xref_Entity_Letters : array (Entity_Kind) of Character := + Xref_Entity_Letters : constant array (Entity_Kind) of Character := (E_Abstract_State => '@', E_Access_Attribute_Type => 'P', E_Access_Protected_Subprogram_Type => 'P', diff --git a/gcc/ada/osint-c.adb b/gcc/ada/osint-c.adb index dcbace26fa1..a24a5a73894 100644 --- a/gcc/ada/osint-c.adb +++ b/gcc/ada/osint-c.adb @@ -446,7 +446,10 @@ package body Osint.C is if NL <= EL or else (Name (NL - EL + Name'First .. Name'Last) /= Ext - and then Name (NL - 2 + Name'First .. Name'Last) /= ".o") + and then Name (NL - 2 + Name'First .. Name'Last) /= ".o" + and then + (not Generate_C_Code + or else Name (NL - 2 + Name'First .. Name'Last) /= ".c")) then Fail ("incorrect object file extension"); end if; diff --git a/gcc/ada/output.adb b/gcc/ada/output.adb index 9261519b24b..fdfb7330a20 100644 --- a/gcc/ada/output.adb +++ b/gcc/ada/output.adb @@ -31,6 +31,17 @@ package body Output is + Buffer : String (1 .. Buffer_Max + 1) := (others => '*'); + for Buffer'Alignment use 4; + -- Buffer used to build output line. We do line buffering because it is + -- needed for the support of the debug-generated-code option (-gnatD). Note + -- any attempt to write more output to a line than can fit in the buffer + -- will be silently ignored. The alignment clause improves the efficiency + -- of the save/restore procedures. + + Next_Col : Positive range 1 .. Buffer'Length + 1 := 1; + -- Column about to be written + Current_FD : File_Descriptor := Standout; -- File descriptor for current output diff --git a/gcc/ada/output.ads b/gcc/ada/output.ads index 0fe58edeeae..5fe0d44a9c2 100644 --- a/gcc/ada/output.ads +++ b/gcc/ada/output.ads @@ -203,20 +203,6 @@ package Output is -- Dump contents of string followed by blank, Boolean, line return private - -- Note: the following buffer and column position are maintained by the - -- subprograms defined in this package, and cannot be directly modified or - -- accessed by a client. - - Buffer : String (1 .. Buffer_Max + 1) := (others => '*'); - for Buffer'Alignment use 4; - -- Buffer used to build output line. We do line buffering because it is - -- needed for the support of the debug-generated-code option (-gnatD). Note - -- any attempt to write more output to a line than can fit in the buffer - -- will be silently ignored. The alignment clause improves the efficiency - -- of the save/restore procedures. - - Next_Col : Positive range 1 .. Buffer'Length + 1 := 1; - -- Column about to be written type Saved_Output_Buffer is record Buffer : String (1 .. Buffer_Max + 1); diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index c34113a7da7..6ce790895d3 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -107,7 +107,7 @@ package Restrict is -- to implement pragma Restrictions (No_Implementation_Restrictions) (which -- is why this restriction itself is excluded from the list). - Implementation_Restriction : array (All_Restrictions) of Boolean := + Implementation_Restriction : constant array (All_Restrictions) of Boolean := (Simple_Barriers => True, No_Calendar => True, No_Default_Initialization => True, diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads index 4f5bb57d744..2acce02ea19 100644 --- a/gcc/ada/scos.ads +++ b/gcc/ada/scos.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2009-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2015, 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- -- @@ -360,7 +360,8 @@ package SCOs is Col : Column_Number; end record; - No_Source_Location : Source_Location := (No_Line_Number, No_Column_Number); + No_Source_Location : constant Source_Location := + (No_Line_Number, No_Column_Number); type SCO_Table_Entry is record From : Source_Location := No_Source_Location; diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads index d71acb33140..a8fa47139ec 100644 --- a/gcc/ada/sem_attr.ads +++ b/gcc/ada/sem_attr.ads @@ -46,7 +46,8 @@ package Sem_Attr is -- in GNAT, as well as constructing an array of flags indicating which -- attributes these are. - Attribute_Impl_Def : Attribute_Class_Array := Attribute_Class_Array'( + Attribute_Impl_Def : constant Attribute_Class_Array := + Attribute_Class_Array'( ------------------ -- Abort_Signal -- diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 4d696c49b19..9e873745e70 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -4328,8 +4328,12 @@ package body Sem_Prag is begin Check_Arg_Is_Local_Name (Arg); + -- If it came from an aspect, we want to give the error just as if it + -- came from source. + if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg))) - and then Comes_From_Source (N) + and then (Comes_From_Source (N) + or else Present (Corresponding_Aspect (Parent (Arg)))) then Error_Pragma_Arg ("argument for pragma% must be library level entity", Arg); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 3512a0a9e3b..59194cf2d26 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -4223,6 +4223,14 @@ package body Sem_Util is then Id := Defining_Entity (Incomplete_View (Parent (B_Type))); + -- If T is a derived from a type with an incomplete view declared + -- elsewhere, that incomplete view is irrelevant, we want the + -- operations in the scope of T. + + if Scope (Id) /= Scope (B_Type) then + Id := Next_Entity (B_Type); + end if; + else Id := Next_Entity (B_Type); end if; diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index 4f565ceb2f4..977d00337f8 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -387,15 +387,6 @@ package body Switch.C is Osint.Fail ("-gnatd.b must be first if combined " & "with other switches"); - - -- Special check, -gnatd.V must occur after -gnatc - - elsif C = 'V' - and then Operating_Mode /= Check_Semantics - then - Osint.Fail - ("gnatd.V requires previous occurrence " - & "of -gnatc"); end if; -- Not a dotted flag diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 8b21b10ca4d..10756075bf3 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -109,8 +109,9 @@ package Types is Character range Character'Val (16#80#) .. Character'Val (16#FF#); -- 8-bit Characters with the upper bit set - type Character_Ptr is access all Character; - type String_Ptr is access all String; + type Character_Ptr is access all Character; + type String_Ptr is access all String; + type String_Ptr_Const is access constant String; -- Standard character and string pointers procedure Free is new Unchecked_Deallocation (String, String_Ptr); @@ -896,7 +897,7 @@ package Types is type Reason_Kind is (CE_Reason, PE_Reason, SE_Reason); -- Categorization of reason codes by exception raised - Rkind : array (RT_Exception_Code range <>) of Reason_Kind := + Rkind : constant array (RT_Exception_Code range <>) of Reason_Kind := (CE_Access_Check_Failed => CE_Reason, CE_Access_Parameter_Is_Null => CE_Reason, CE_Discriminant_Check_Failed => CE_Reason, -- 2.30.2