diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 32 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 59 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/gnat_rm.texi | 3 | ||||
| -rw-r--r-- | gcc/ada/make.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/makeutl.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/makeutl.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/prj-conf.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/prj-conf.ads | 5 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 24 |
11 files changed, 124 insertions, 25 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b406325..d5a1fde 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,35 @@ +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 diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 315b076..66c0d91 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -767,6 +767,7 @@ package body Checks is 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 diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index daa6b16..827a6dc 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -4440,7 +4440,8 @@ package body Exp_Attr is ---------- -- 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 : @@ -4512,9 +4513,36 @@ package body Exp_Attr is 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); @@ -5563,6 +5591,33 @@ package body Exp_Attr is -- 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); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 7c84763..5b9eb86 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -12559,7 +12559,7 @@ package body Exp_Ch4 is -- 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. diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index e94dd9d..9790b8e 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -1779,7 +1779,8 @@ as overflow checking could be guaranteed. 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. diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index c2524a1..74be698 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -5327,7 +5327,7 @@ package body Make is 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); diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index d977251..b0dfe35 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -3173,7 +3173,7 @@ package body Makeutl is 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 @@ -3312,7 +3312,7 @@ package body Makeutl 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 @@ -3432,7 +3432,7 @@ package body Makeutl is 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.", diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index 88c9c98..370f32a 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -323,7 +323,7 @@ package Makeutl is 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 diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb index b0dfceb..1becd70 100644 --- a/gcc/ada/prj-conf.adb +++ b/gcc/ada/prj-conf.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -721,7 +721,7 @@ package body Prj.Conf is 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 @@ -748,7 +748,7 @@ package body Prj.Conf is 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; @@ -1518,7 +1518,8 @@ package body Prj.Conf is 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 @@ -1551,7 +1552,7 @@ package body Prj.Conf is 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); diff --git a/gcc/ada/prj-conf.ads b/gcc/ada/prj-conf.ads index 70382c3..df830ad 100644 --- a/gcc/ada/prj-conf.ads +++ b/gcc/ada/prj-conf.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -218,7 +218,8 @@ package Prj.Conf is 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 diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index ebbbdc4..bda9f35 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -2409,6 +2409,8 @@ package body Sem_Attr is 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 @@ -4835,17 +4837,20 @@ package body Sem_Attr is 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 @@ -5739,17 +5744,20 @@ package body Sem_Attr is 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 |