OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2015-11-12  Bob Duff  <duff@adacore.com>

	* 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  <moy@adacore.com>

	* lib-xref-spark_specific.adb
	(Is_Constant_Object_Without_Variable_Input): Add special case
	for imported constants.

2015-11-12  Philippe Gil  <gil@adacore.com>

	* g-debpoo.adb (Allocate): Avoid having allocations not handled.

2015-11-12  Ed Schonberg  <schonberg@adacore.com>

	* 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  <schonberg@adacore.com>

	* 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  <charlet@adacore.com>

	* 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  <lambourg@adacore.com>

	* init.c: Properly adjust PC values in case of signals.

2015-11-12  Bob Duff  <duff@adacore.com>

	* 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
This commit is contained in:
Arnaud Charlet 2015-11-12 14:25:40 +01:00
parent a989bcc3f5
commit aff557c74c
20 changed files with 193 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
gcc/ada/ChangeLog
View File

@ -1,3 +1,48 @@
2015-11-12 Bob Duff <duff@adacore.com>
* 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 <moy@adacore.com>
* lib-xref-spark_specific.adb
(Is_Constant_Object_Without_Variable_Input): Add special case
for imported constants.
2015-11-12 Philippe Gil <gil@adacore.com>
* g-debpoo.adb (Allocate): Avoid having allocations not handled.
2015-11-12 Ed Schonberg <schonberg@adacore.com>
* 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 <schonberg@adacore.com>
* 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 <charlet@adacore.com>
* 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 <lambourg@adacore.com>
* init.c: Properly adjust PC values in case of signals.
2015-11-12 Bob Duff <duff@adacore.com>
* 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 <charlet@adacore.com>
* switch-c.adb, gnat1drv.adb, opt.ads: Reserve -gnateg for generation

24
gcc/ada/checks.adb
View File

@ -2878,12 +2878,36 @@ 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
-- 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;
-- Return if we know expression is definitely in the range of the target

3
gcc/ada/exp_aggr.adb
View File

@ -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;

37
gcc/ada/exp_util.adb
View File

@ -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.
-- If E's scope is axiomatized, E is axiomatized
declare
First_Ax_Parent_Scope : Entity_Id := Empty;
begin
if Present (Scope (E)) then
First_Ax_Parent_Scope :=
Containing_Package_With_Ext_Axioms (Scope (E));
end if;
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
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;
-------------------------------

9
gcc/ada/g-debpoo.adb
View File

@ -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
<<Allocate_Label>>
@ -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;

8
gcc/ada/gnat1drv.adb
View File

@ -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;

22
gcc/ada/impunit.adb
View File

@ -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

39
gcc/ada/init.c
View File

@ -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 <arch/../regs.h>
#ifndef __RTP__
#include <sigLib.h>
#else
#include <signal.h>
#include <regs.h>
#include <ucontext.h>
#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,

4
gcc/ada/lib-xref-spark_specific.adb
View File

@ -445,8 +445,12 @@ package body SPARK_Specific is
Decl := Parent (E);
end if;
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 =>

2
gcc/ada/lib-xref.ads
View File

@ -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',

5
gcc/ada/osint-c.adb
View File

@ -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;

11
gcc/ada/output.adb
View File

@ -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

14
gcc/ada/output.ads
View File

@ -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);

2
gcc/ada/restrict.ads
View File

@ -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,

5
gcc/ada/scos.ads
View File

@ -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;

3
gcc/ada/sem_attr.ads
View File

@ -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 --

6
gcc/ada/sem_prag.adb
View File

@ -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);

8
gcc/ada/sem_util.adb
View File

@ -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;

9
gcc/ada/switch-c.adb
View File

@ -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

3
gcc/ada/types.ads
View File

@ -111,6 +111,7 @@ package Types is
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,