+2013-01-03 Emmanuel Briot <briot@adacore.com>
+
+ * xref_lib.adb (Parse_Identifier_Info): Fix handling of arrays, which
+ have information in the ALI file for both the index and the component
+ types.
+
+2013-01-03 Emmanuel Briot <briot@adacore.com>
+
+ * projects.texi: Fix error in documenting the project path
+ computed for an aggregate project.
+
+2013-01-03 Javier Miranda <miranda@adacore.com>
+
+ * sem_warn.adb (Warn_On_Overlapping_Actuals): Adding documentation
+ plus restricting the functionality of this routine to cover the
+ cases described in the Ada 2012 reference manual. The previous
+ extended support is now available under -gnatX.
+ * s-tassta.adb (Finalize_Global_Tasks): Addition of a dummy
+ variable to call Timed_Sleep. Required to avoid warning on
+ overlapping out-mode actuals.
+ * opt.ads (Extensions_Allowed): Update documentation.
+
+2013-01-03 Tristan Gingold <gingold@adacore.com>
+
+ * s-arit64.ads: Use Multiply_With_Ovflo_Check as __gnat_mulv64.
+ * arit64.c: Removed
+ * gcc-interface/Makefile.in: Remove reference to arit64.c.
+
+2013-01-03 Thomas Quinot <quinot@adacore.com>
+
+ * checks.adb, checks.ads (Apply_Address_Clause_Check): The check must
+ be generated at the start of the freeze actions for the entity, not
+ before (or after) the freeze node.
+
+2013-01-03 Thomas Quinot <quinot@adacore.com>
+
+ * exp_aggr.adb (Exp_Aggr.Convert_Aggregate_In_Obj_Decl):
+ Reorganize code to capture initialization statements in a block,
+ so that freeze nodes are excluded from the captured block.
+
2013-01-03 Thomas Quinot <quinot@adacore.com>
* exp_ch11.adb: Minor reformatting.
+++ /dev/null
-/****************************************************************************
- * *
- * GNAT COMPILER COMPONENTS *
- * *
- * A R I T 6 4 . C *
- * *
- * C Implementation File *
- * *
- * Copyright (C) 2009-2012, 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- *
- * ware Foundation; either version 3, or (at your option) any later ver- *
- * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
- * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
- * or FITNESS FOR A PARTICULAR PURPOSE. *
- * *
- * As a special exception under Section 7 of GPL version 3, you are granted *
- * additional permissions described in the GCC Runtime Library Exception, *
- * version 3.1, as published by the Free Software Foundation. *
- * *
- * You should have received a copy of the GNU General Public License and *
- * a copy of the GCC Runtime Library Exception along with this program; *
- * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see *
- * <http://www.gnu.org/licenses/>. *
- * *
- * GNAT was originally developed by the GNAT team at New York University. *
- * Extensive contributions were provided by Ada Core Technologies Inc. *
- * *
- ****************************************************************************/
-
-extern void __gnat_rcheck_CE_Overflow_Check(char *file, int line)
- __attribute__ ((__noreturn__));
-
-long long int __gnat_mulv64 (long long int x, long long int y)
-{
- unsigned neg = (x >= 0) ^ (y >= 0);
- long long unsigned xa = x >= 0 ? (long long unsigned) x
- : -(long long unsigned) x;
- long long unsigned ya = y >= 0 ? (long long unsigned) y
- : -(long long unsigned) y;
- unsigned xhi = (unsigned) (xa >> 32);
- unsigned yhi = (unsigned) (ya >> 32);
- unsigned xlo = (unsigned) xa;
- unsigned ylo = (unsigned) ya;
- long long unsigned mid
- = xhi ? (long long unsigned) xhi * (long long unsigned) ylo
- : (long long unsigned) yhi * (long long unsigned) xlo;
- long long unsigned low = (long long unsigned) xlo * (long long unsigned) ylo;
-
- if ((xhi && yhi) || mid + (low >> 32) > 0x7fffffff + neg)
- __gnat_rcheck_CE_Overflow_Check (__FILE__, __LINE__);
-
- low += ((long long unsigned) (unsigned) mid) << 32;
-
- return (long long int) (neg ? -low : low);
-}
--------------------------------
procedure Apply_Address_Clause_Check (E : Entity_Id; N : Node_Id) is
+ pragma Assert (Nkind (N) = N_Freeze_Entity);
+
AC : constant Node_Id := Address_Clause (E);
Loc : constant Source_Ptr := Sloc (AC);
Typ : constant Entity_Id := Etype (E);
Remove_Side_Effects (Expr);
end if;
- Insert_After_And_Analyze (N,
+ if No (Actions (N)) then
+ Set_Actions (N, New_List);
+ end if;
+
+ Prepend_To (Actions (N),
Make_Raise_Program_Error (Loc,
Condition =>
Make_Op_Ne (Loc,
(RTE (RE_Integer_Address), Expr),
Right_Opnd =>
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (E, Loc),
+ Prefix => New_Occurrence_Of (E, Loc),
Attribute_Name => Name_Alignment)),
Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
- Reason => PE_Misaligned_Address_Value),
- Suppress => All_Checks);
+ Reason => PE_Misaligned_Address_Value));
+ Analyze (First (Actions (N)), Suppress => All_Checks);
return;
end if;
-- are enabled, then this procedure generates a check that the specified
-- address has an alignment consistent with the alignment of the object,
-- raising PE if this is not the case. The resulting check (if one is
- -- generated) is inserted before node N. check is also made for the case of
- -- a clear overlay situation that the size of the overlaying object is not
+ -- generated) is prepended to the Actions list of N_Freeze_Entity node N.
+ -- Note that the check references E'Alignment, so it cannot be emitted
+ -- before N (its freeze node), otherwise this would cause an illegal
+ -- access before elaboration error in GIGI. For the case of a clear overlay
+ -- situation, we also check that the size of the overlaying object is not
-- larger than the overlaid object.
procedure Apply_Arithmetic_Overflow_Check (N : Node_Id);
Loc : constant Source_Ptr := Sloc (Aggr);
Typ : constant Entity_Id := Etype (Aggr);
Occ : constant Node_Id := New_Occurrence_Of (Obj, Loc);
- Blk : Node_Id := Empty;
- Ins : Node_Id;
function Discriminants_Ok return Boolean;
-- If the object type is constrained, the discriminants in the
(Aggr,
Sec_Stack =>
Is_Controlled (Typ) or else Has_Controlled_Component (Typ));
- Ins := N;
+ end if;
+
+ declare
+ Node_After : constant Node_Id := Next (N);
+ Init_Node : Node_Id;
+ Blk : Node_Id;
+ Init_Actions : constant List_Id := New_List;
+ begin
+ Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ));
- -- Need to Set_Initialization_Statements??? (see below)
+ -- Move inserted, analyzed actions to Init_Actions, but skip over
+ -- freeze nodes as these need to remain in the proper scope.
- else
- -- Capture initialization statements within an identified block
- -- statement, as we might need to move them to the freeze actions
- -- of Obj later on if a representation clause (such as an address
- -- clause) makes it necessary to delay freezing.
-
- Ins := Make_Null_Statement (Loc);
- Blk := Make_Block_Statement (Loc,
- Declarations => New_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Ins)));
- Insert_Action_After (N, Blk);
- Set_Initialization_Statements (Obj, Blk);
- end if;
+ Init_Node := N;
- Insert_Actions_After (Ins, Late_Expansion (Aggr, Typ, Occ));
+ while Next (Init_Node) /= Node_After loop
+ if Nkind (Next (Init_Node)) = N_Freeze_Entity then
+ Next (Init_Node);
+ else
+ Append_To (Init_Actions, Remove_Next (Init_Node));
+ end if;
+ end loop;
+
+ if not Is_Empty_List (Init_Actions) then
+ Blk := Make_Block_Statement (Loc,
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Init_Actions));
+ Insert_Action_After (Init_Node, Blk);
+ Set_Initialization_Statements (Obj, Blk);
+ end if;
+ end;
Set_No_Initialization (N);
Initialize_Discriminants (N, Typ);
end Convert_Aggr_In_Object_Decl;
# LIBGNAT_SRCS is the list of all C files (including headers) of the runtime
# library. LIBGNAT_OBJS is the list of object files for libgnat.
# thread.c is special as put into GNATRTL_TASKING_OBJS by Makefile.rtl
-LIBGNAT_OBJS = adadecode.o adaint.o argv.o arit64.o aux-io.o \
+LIBGNAT_OBJS = adadecode.o adaint.o argv.o aux-io.o \
cal.o cio.o cstreams.o ctrl_c.o \
env.o errno.o exit.o expect.o final.o \
init.o initialize.o locales.o mkdir.o \
Extensions_Allowed : Boolean := False;
-- GNAT
-- Set to True by switch -gnatX if GNAT specific language extensions
- -- are allowed. Currently there are no such defined extensions.
+ -- are allowed.
type External_Casing_Type is (
As_Is, -- External names cased as they appear in the Ada source
Each aggregate project has its own (that is if agg1.gpr includes
agg2.gpr, they can potentially both have a different project path).
-This project path is defined as the concatenation, in that order, of
-the current directory, followed by the command line -aP switches,
-then the directories from the Project_Path attribute, then the
-directories from the GPR_PROJECT_PATH and ADA_PROJECT_PATH env.
-variables, and finally the predefined directories.
+
+This project path is defined as the concatenation, in that order, of:
+
+@itemize @bullet
+@item the current directory;
+@item followed by the command line -aP switches;
+@item then the directories from the GPR_PROJECT_PATH and ADA_PROJECT_PATH environment
+variables;
+@item then the directories from the Project_Path attribute;
+@item and finally the predefined directories.
+@end itemize
In the example above, agg2.gpr's project path is not influenced by
the attribute agg1'Project_Path, nor is agg1 influenced by
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
-- signed integer values in cases where either overflow checking is
-- required, or intermediate results are longer than 64 bits.
+pragma Restrictions (No_Elaboration_Code);
+-- Allow direct call from gigi generated code
+
with Interfaces;
package System.Arith_64 is
-- bits, otherwise returns the 64-bit signed integer difference.
function Multiply_With_Ovflo_Check (X, Y : Int64) return Int64;
+ pragma Export (C, Multiply_With_Ovflo_Check, "__gnat_mulv64");
-- Raises Constraint_Error if product of operands overflows 64
-- bits, otherwise returns the 64-bit signed integer product.
+ -- GIGI may also call this routine directly.
procedure Scaled_Divide
(X, Y, Z : Int64;
procedure Finalize_Global_Tasks is
Self_ID : constant Task_Id := STPO.Self;
- Ignore : Boolean;
- pragma Unreferenced (Ignore);
+ Ignore_1 : Boolean;
+ Ignore_2 : Boolean;
+ pragma Unreferenced (Ignore_1, Ignore_2);
function State
(Int : System.Interrupt_Management.Interrupt_ID) return Character;
Timed_Sleep
(Self_ID, 0.01, System.OS_Primitives.Relative,
- Self_ID.Common.State, Ignore, Ignore);
+ Self_ID.Common.State, Ignore_1, Ignore_2);
end loop;
end if;
Timed_Sleep
(Self_ID, 0.01, System.OS_Primitives.Relative,
- Self_ID.Common.State, Ignore, Ignore);
+ Self_ID.Common.State, Ignore_1, Ignore_2);
Unlock (Self_ID);
Act1, Act2 : Node_Id;
Form1, Form2 : Entity_Id;
+ function Is_Covered_Formal (Formal : Node_Id) return Boolean;
+ -- Return True if Formal is covered by the Ada 2012 rule. Under -gnatX
+ -- the rule is extended to cover record and array types.
+
+ function Refer_Same_Object (Act1, Act2 : Node_Id) return Boolean;
+ -- Two names are known to refer to the same object if the two names
+ -- are known to denote the same object; or one of the names is a
+ -- selected_component, indexed_component, or slice and its prefix is
+ -- known to refer to the same object as the other name; or one of the
+ -- two names statically denotes a renaming declaration whose renamed
+ -- object_name is known to refer to the same object as the other name
+ -- (RM 6.4.1(6.11/3))
+
+ -----------------------
+ -- Refer_Same_Object --
+ -----------------------
+
+ function Refer_Same_Object (Act1, Act2 : Node_Id) return Boolean is
+ begin
+ return Denotes_Same_Object (Act1, Act2)
+ or else Denotes_Same_Prefix (Act1, Act2);
+ end Refer_Same_Object;
+
+ -----------------------
+ -- Is_Covered_Formal --
+ -----------------------
+
+ function Is_Covered_Formal (Formal : Node_Id) return Boolean is
+ begin
+ -- Ada 2012 rule
+
+ if not Extensions_Allowed then
+ return
+ Ekind_In (Formal, E_Out_Parameter,
+ E_In_Out_Parameter)
+ and then Is_Elementary_Type (Etype (Formal));
+
+ -- Under -gnatX the rule is extended to cover array and record types
+
+ else
+ return
+ Ekind_In (Formal, E_Out_Parameter,
+ E_In_Out_Parameter)
+ and then (Is_Elementary_Type (Etype (Formal))
+ or else Is_Record_Type (Etype (Formal))
+ or else Is_Array_Type (Etype (Formal)));
+ end if;
+ end Is_Covered_Formal;
+
begin
- if not Warn_On_Overlap then
+ if Ada_Version < Ada_2012 and then not Warn_On_Overlap then
return;
end if;
-- Exclude calls rewritten as enumeration literals
- if Nkind (N) not in N_Subprogram_Call then
+ if Nkind (N) not in N_Subprogram_Call
+ and then Nkind (N) /= N_Entry_Call_Statement
+ then
return;
end if;
- -- Exclude calls to library subprograms. Container operations specify
- -- safe behavior when source and target coincide.
+ -- If a call C has two or more parameters of mode in out or out that are
+ -- of an elementary type, then the call is legal only if for each name
+ -- N that is passed as a parameter of mode in out or out to the call C,
+ -- there is no other name among the other parameters of mode in out or
+ -- out to C that is known to denote the same object (RM 6.4.1(6.15/3))
- if Is_Predefined_File_Name
- (Unit_File_Name (Get_Source_Unit (Sloc (Subp))))
- then
- return;
- end if;
+ -- Under -gnatX the rule is extended to cover array and record types.
Form1 := First_Formal (Subp);
Act1 := First_Actual (N);
while Present (Form1) and then Present (Act1) loop
- if Ekind (Form1) /= E_In_Parameter then
+
+ if Is_Covered_Formal (Form1) then
Form2 := First_Formal (Subp);
Act2 := First_Actual (N);
while Present (Form2) and then Present (Act2) loop
if Form1 /= Form2
- and then Ekind (Form2) /= E_Out_Parameter
- and then
- (Denotes_Same_Object (Act1, Act2)
- or else
- Denotes_Same_Prefix (Act1, Act2))
+ and then Is_Covered_Formal (Form2)
+ and then Refer_Same_Object (Act1, Act2)
then
- -- Exclude generic types and guard against previous errors
+ -- Guard against previous errors
if Error_Posted (N)
or else No (Etype (Act1))
then
null;
- elsif Is_Generic_Type (Etype (Act1))
- or else
- Is_Generic_Type (Etype (Act2))
- then
- null;
-
- -- If the actual is a function call in prefix notation,
- -- there is no real overlap.
+ -- If the actual is a function call in prefix notation,
+ -- there is no real overlap.
elsif Nkind (Act2) = N_Function_Call then
null;
-- intended.
elsif
- Is_By_Reference_Type (Underlying_Type (Etype (Form1)))
+ Present (Underlying_Type (Etype (Form1)))
+ and then
+ (Is_By_Reference_Type (Underlying_Type (Etype (Form1)))
+ or else
+ Convention (Underlying_Type (Etype (Form1)))
+ = Convention_Ada_Pass_By_Reference)
then
null;
+ -- Here we may need to issue message
+
else
+ Error_Msg_Warn := Ada_Version < Ada_2012;
+
declare
Act : Node_Id;
Form : Entity_Id;
end;
end if;
- if Ali (Ptr) = '<'
- or else Ali (Ptr) = '('
- or else Ali (Ptr) = '{'
- then
+ while Ptr <= Ali'Last
+ and then (Ali (Ptr) = '<'
+ or else Ali (Ptr) = '('
+ or else Ali (Ptr) = '{')
+ loop
-- Here we have a type derivation information. The format is
-- <3|12I45> which means that the current entity is derived from the
-- type defined in unit number 3, line 12 column 45. The pipe and
end loop;
Ptr := Ptr + 1;
end if;
- end if;
+ end loop;
-- To find the body, we will have to parse the file too
projects / platform / upstream / gcc.git / commitdiff