+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
-- 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;
-- 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;
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)
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;
-------------------------------
P : Ptr;
Trace : Traceback_Htable_Elem_Ptr;
- Disable_Exit_Value : constant Boolean := Disable;
+ Reset_Disable_At_Exit : Boolean := False;
begin
<<Allocate_Label>>
return;
end if;
+ Reset_Disable_At_Exit := True;
Disable := True;
Pool.Alloc_Count := Pool.Alloc_Count + 1;
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;
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
-- 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;
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
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. */
__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,
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 =>
-- 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',
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;
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
-- 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);
-- 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,
-- --
-- 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- --
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;
-- 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 --
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);
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;
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
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);
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,
projects / thirdparty / gcc.git / commitdiff
