+2014-06-13 Eric Botcazou <ebotcazou@adacore.com>
+
+ * checks.adb (Apply_Address_Clause_Check): Only issue the new
+ warning if the propagation warning is issued.
+
+2014-06-13 Thomas Quinot <quinot@adacore.com>
+
+ * exp_ch4.adb: Minor reformatting.
+
+2014-06-13 Robert Dewar <dewar@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference, case Pred):
+ Handle float range check case (Expand_N_Attribute_Reference,
+ case Succ): Handle float range check case.
+ * sem_attr.adb (Analyze_Attribute, case Pred/Succ): Handle float
+ range check case.
+
+2014-06-13 Vincent Celier <celier@adacore.com>
+
+ * makeutl.ads (Compute_Builder_Switches): Change name of
+ parameter Root_Environment to Env.
+ * prj-conf.adb (Check_Switches): Call Locate_Runtime with the
+ Env parameter of procedure Get_Or_Create_Configuration_File.
+ (Locate_Runtime): Call Find_Rts_In_Path with the Project_Path
+ of new parameter Env.
+ * prj-conf.ads (Locate_Runtime): New parameter Env of type
+ Prj.Tree.Environment.
+
+2014-06-13 Robert Dewar <dewar@adacore.com>
+
+ * gnat_rm.texi: Minor comment clarification for Check_Float_Overflow.
+
2014-06-13 Robert Dewar <dewar@adacore.com>
* exp_attr.adb, exp_ch9.adb, lib-writ.adb, g-comlin.adb: Minor
if Nkind (First (Actions (N))) = N_Raise_Program_Error
and then not Warnings_Off (E)
+ and then Warn_On_Non_Local_Exception
and then Restriction_Active (No_Exception_Propagation)
then
Error_Msg_N
----------
-- 1. Deal with enumeration types with holes
- -- 2. For floating-point, generate call to attribute function
+ -- 2. For floating-point, generate call to attribute function and deal
+ -- with range checking if Check_Float_Overflow modde.
-- 3. For other cases, deal with constraint checking
when Attribute_Pred => Pred :
Analyze_And_Resolve (N, Typ);
-- For floating-point, we transform 'Pred into a call to the Pred
- -- floating-point attribute function in Fat_xxx (xxx is root type)
+ -- floating-point attribute function in Fat_xxx (xxx is root type).
elsif Is_Floating_Point_Type (Ptyp) then
+
+ -- Handle case of range check. The Do_Range_Check flag is set only
+ -- in Check_Float_Overflow mode, and what we need is a specific
+ -- check against typ'First, since that is the only overflow case.
+
+ declare
+ Expr : constant Node_Id := First (Exprs);
+ begin
+ if Do_Range_Check (Expr) then
+ Set_Do_Range_Check (Expr, False);
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => Duplicate_Subexpr (Expr),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_First,
+ Prefix =>
+ New_Occurrence_Of (Base_Type (Ptyp), Loc))),
+ Reason => CE_Range_Check_Failed),
+ Suppress => All_Checks);
+ end if;
+ end;
+
+ -- Transform into call to attribute function
+
Expand_Fpt_Attribute_R (N);
Analyze_And_Resolve (N, Typ);
-- floating-point attribute function in Fat_xxx (xxx is root type)
elsif Is_Floating_Point_Type (Ptyp) then
+
+ -- Handle case of range check. The Do_Range_Check flag is set only
+ -- in Check_Float_Overflow mode, and what we need is a specific
+ -- check against typ'Last, since that is the only overflow case.
+
+ declare
+ Expr : constant Node_Id := First (Exprs);
+ begin
+ if Do_Range_Check (Expr) then
+ Set_Do_Range_Check (Expr, False);
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => Duplicate_Subexpr (Expr),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Last,
+ Prefix =>
+ New_Occurrence_Of (Base_Type (Ptyp), Loc))),
+ Reason => CE_Range_Check_Failed),
+ Suppress => All_Checks);
+ end if;
+ end;
+
+ -- Transform into call to attribute function
+
Expand_Fpt_Attribute_R (N);
Analyze_And_Resolve (N, Typ);
-- hook pointer is null.
procedure Find_Enclosing_Contexts (N : Node_Id);
- -- Find the logical context where N appears, and initializae
+ -- Find the logical context where N appears, and initialize
-- Hook_Context and Finalization_Context accordingly. Also
-- sets Finalize_Always.
The @code{Check_Float_Overflow}
configuration pragma achieves this effect. If a unit is compiled
subject to this configuration pragma, then all operations
-on predefined floating-point types will be treated as
+on predefined floating-point types including operations on
+base types of these floating-point types will be treated as
though those types were constrained, and overflow checks
will be generated. The @code{Constraint_Error}
exception is raised if the result is out of range.
if Compute_Builder then
Do_Compute_Builder_Switches
(Project_Tree => Project_Tree,
- Root_Environment => Root_Environment,
+ Env => Root_Environment,
Main_Project => Main_Project,
Only_For_Lang => Name_Ada);
procedure Compute_Builder_Switches
(Project_Tree : Project_Tree_Ref;
- Root_Environment : in out Prj.Tree.Environment;
+ Env : in out Prj.Tree.Environment;
Main_Project : Project_Id;
Only_For_Lang : Name_Id := No_Name)
is
and then Default_Switches_Array /= No_Array
then
Prj.Err.Error_Msg
- (Root_Environment.Flags,
+ (Env.Flags,
"Default_Switches forbidden in presence of " &
"Global_Compilation_Switches. Use Switches instead.",
Project_Tree.Shared.Arrays.Table
Name_Len := Name_Len + Name_Len;
Prj.Err.Error_Msg
- (Root_Environment.Flags,
+ (Env.Flags,
'"' & Name_Buffer (1 .. Name_Len) &
""" is not a builder switch. Consider moving " &
"it to Global_Compilation_Switches.",
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2014, 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- --
procedure Compute_Builder_Switches
(Project_Tree : Project_Tree_Ref;
- Root_Environment : in out Prj.Tree.Environment;
+ Env : in out Prj.Tree.Environment;
Main_Project : Project_Id;
Only_For_Lang : Name_Id := No_Name);
-- Compute the builder switches and global compilation switches. Every time
-- --
-- B o d y --
-- --
--- Copyright (C) 2006-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2014, 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- --
Set_Runtime_For
(Name_Ada,
Name_Buffer (7 .. Name_Len));
- Locate_Runtime (Name_Ada, Project_Tree);
+ Locate_Runtime (Name_Ada, Project_Tree, Env);
end if;
elsif Name_Len > 7
if not Runtime_Name_Set_For (Lang) then
Set_Runtime_For (Lang, RTS);
- Locate_Runtime (Lang, Project_Tree);
+ Locate_Runtime (Lang, Project_Tree, Env);
end if;
end;
end if;
procedure Locate_Runtime
(Language : Name_Id;
- Project_Tree : Prj.Project_Tree_Ref)
+ Project_Tree : Prj.Project_Tree_Ref;
+ Env : Prj.Tree.Environment)
is
function Is_Base_Name (Path : String) return Boolean;
-- Returns True if Path has no directory separator
begin
if not Is_Base_Name (RTS_Name) then
Full_Path :=
- Find_Rts_In_Path (Root_Environment.Project_Path, RTS_Name);
+ Find_Rts_In_Path (Env.Project_Path, RTS_Name);
if Full_Path = null then
Fail_Program (Project_Tree, "cannot find RTS " & RTS_Name);
-- --
-- S p e c --
-- --
--- Copyright (C) 2006-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2014, 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- --
procedure Locate_Runtime
(Language : Name_Id;
- Project_Tree : Prj.Project_Tree_Ref);
+ Project_Tree : Prj.Project_Tree_Ref;
+ Env : Prj.Tree.Environment);
-- If RTS_Name is a base name (a name without path separator), then
-- do nothing. Otherwise, convert it to an absolute path (possibly by
-- searching it in the project path) and call Set_Runtime_For with the
end if;
end if;
+ -- Cases where prefix must be resolvable by itself
+
if Is_Overloaded (P)
and then Aname /= Name_Access
and then Aname /= Name_Address
if Is_Real_Type (P_Type) or else Is_Boolean_Type (P_Type) then
Error_Msg_Name_1 := Aname;
Error_Msg_Name_2 := Chars (P_Type);
- Check_SPARK_Restriction
- ("attribute% is not allowed for type%", P);
+ Check_SPARK_Restriction ("attribute% is not allowed for type%", P);
end if;
Resolve (E1, P_Base_Type);
Set_Etype (N, P_Base_Type);
- -- Nothing to do for real type case
+ -- For real types, enable range check in Check_Overflow_Mode only
if Is_Real_Type (P_Type) then
- null;
+ if Check_Float_Overflow
+ and then not Range_Checks_Suppressed (P_Base_Type)
+ then
+ Enable_Range_Check (E1);
+ end if;
-- If not modular type, test for overflow check required
if Is_Real_Type (P_Type) or else Is_Boolean_Type (P_Type) then
Error_Msg_Name_1 := Aname;
Error_Msg_Name_2 := Chars (P_Type);
- Check_SPARK_Restriction
- ("attribute% is not allowed for type%", P);
+ Check_SPARK_Restriction ("attribute% is not allowed for type%", P);
end if;
Resolve (E1, P_Base_Type);
Set_Etype (N, P_Base_Type);
- -- Nothing to do for real type case
+ -- For real types, enable range check in Check_Overflow_Mode only
if Is_Real_Type (P_Type) then
- null;
+ if Check_Float_Overflow
+ and then not Range_Checks_Suppressed (P_Base_Type)
+ then
+ Enable_Range_Check (E1);
+ end if;
-- If not modular type, test for overflow check required
projects / thirdparty / gcc.git / commitdiff
