From 8fa4b2980bd08af799e33bf24d06714e5a558d3d Mon Sep 17 00:00:00 2001 From: charlet Date: Thu, 11 Apr 2013 09:31:53 +0000 Subject: [PATCH] 2013-04-11 Robert Dewar * s-osprim-mingw.adb, sem_ch3.adb, sem_prag.adb, sem_util.adb. makeutl.adb, sem_ch8.adb: Minor reformatting. 2013-04-11 Vincent Celier * gnat_ugn.texi: Minor fixes for VMS. * ug_words: Minor addition: -gnato? => /OVERFLOW_CHECKS=?. 2013-04-11 Robert Dewar * usage.adb (Usage): Minor edit to -gnatW message 2013-04-11 Robert Dewar * exp_aggr.adb (Expand_N_Aggregate): Add circuit for handling others for string literal case. Also add big ??? comment about this new code, which should be redundant, but is not. * sem_eval.adb (Eval_Concatenation): Handle non-static case properly (Eval_String_Literal): Handle non-static literal properly git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@197744 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 22 +++++++++++ gcc/ada/exp_aggr.adb | 94 +++++++++++++++++++++++++++++++++++++++++++++- gcc/ada/gnat_ugn.texi | 26 ++++++------- gcc/ada/makeutl.adb | 29 +++++++------- gcc/ada/s-osprim-mingw.adb | 33 ++++++++-------- gcc/ada/sem_ch3.adb | 1 - gcc/ada/sem_ch8.adb | 10 ++--- gcc/ada/sem_eval.adb | 76 +++++++++++++++++++++++++------------ gcc/ada/sem_prag.adb | 4 +- gcc/ada/sem_util.adb | 2 +- gcc/ada/ug_words | 1 + gcc/ada/usage.adb | 4 +- 12 files changed, 226 insertions(+), 76 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3ec3e29..9118864 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,25 @@ +2013-04-11 Robert Dewar + + * s-osprim-mingw.adb, sem_ch3.adb, sem_prag.adb, sem_util.adb. + makeutl.adb, sem_ch8.adb: Minor reformatting. + +2013-04-11 Vincent Celier + + * gnat_ugn.texi: Minor fixes for VMS. + * ug_words: Minor addition: -gnato? => /OVERFLOW_CHECKS=?. + +2013-04-11 Robert Dewar + + * usage.adb (Usage): Minor edit to -gnatW message + +2013-04-11 Robert Dewar + + * exp_aggr.adb (Expand_N_Aggregate): Add circuit for handling + others for string literal case. Also add big ??? comment about + this new code, which should be redundant, but is not. + * sem_eval.adb (Eval_Concatenation): Handle non-static case + properly (Eval_String_Literal): Handle non-static literal properly + 2013-03-20 Tobias Burnus * i-fortra.ads: Update comment, add Ada 2012's optional diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 3b9d06f..ab42366 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -59,6 +59,7 @@ with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; +with Stringt; use Stringt; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -5160,9 +5161,100 @@ package body Exp_Aggr is procedure Expand_N_Aggregate (N : Node_Id) is begin + -- Record aggregate case + if Is_Record_Type (Etype (N)) then Expand_Record_Aggregate (N); + + -- Array aggregate case + else + -- A special case, if we have a string subtype with bounds 1 .. N, + -- where N is known at compile time, and the aggregate is of the + -- form (others => 'x'), and N is less than 80 (an arbitrary limit + -- for now), then replace the aggregate by the equivalent string + -- literal (but do not mark it as static since it is not!) + + -- Note: this entire circuit is redundant with respect to code in + -- Expand_Array_Aggregate that collapses others choices to positional + -- form, but there are two problems with that circuit: + + -- a) It is limited to very small cases due to ill-understood + -- interations with bootstrapping. That limit is removed by + -- use of the No_Implicit_Loops restriction. + + -- b) It erroneously ends up with the resulting expressions being + -- considered static when they are not. For example, the + -- following test should fail: + + -- pragma Restrictions (No_Implicit_Loops); + -- package NonSOthers4 is + -- B : constant String (1 .. 6) := (others => 'A'); + -- DH : constant String (1 .. 8) := B & "BB"; + -- X : Integer; + -- pragma Export (C, X, Link_Name => DH); + -- end; + + -- But it succeeds (DH looks static to pragma Export) + + -- To be sorted out! ??? + + if Present (Component_Associations (N)) then + declare + CA : constant Node_Id := First (Component_Associations (N)); + MX : constant := 80; + + begin + if Nkind (First (Choices (CA))) = N_Others_Choice + and then Nkind (Expression (CA)) = N_Character_Literal + then + declare + T : constant Entity_Id := Etype (N); + X : constant Node_Id := First_Index (T); + EC : constant Node_Id := Expression (CA); + CV : constant Uint := Char_Literal_Value (EC); + CC : constant Int := UI_To_Int (CV); + + begin + if Nkind (X) = N_Range + and then Compile_Time_Known_Value (Low_Bound (X)) + and then Expr_Value (Low_Bound (X)) = 1 + and then Compile_Time_Known_Value (High_Bound (X)) + then + declare + Hi : constant Uint := Expr_Value (High_Bound (X)); + + begin + if Hi <= MX then + Start_String; + + for J in 1 .. UI_To_Int (Hi) loop + Store_String_Char (Char_Code (CC)); + end loop; + + Rewrite (N, + Make_String_Literal (Sloc (N), + Strval => End_String)); + + if CC >= Int (2 ** 16) then + Set_Has_Wide_Wide_Character (N); + elsif CC >= Int (2 ** 8) then + Set_Has_Wide_Character (N); + end if; + + Analyze_And_Resolve (N, T); + Set_Is_Static_Expression (N, False); + return; + end if; + end; + end if; + end; + end if; + end; + end if; + + -- Not that special case, so normal expansion of array aggregate + Expand_Array_Aggregate (N); end if; exception diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 1af8a94..ad48a21 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -4419,7 +4419,7 @@ cases; if two digits are given, then the first applies outside assertions, and the second within assertions. If no digits follow the @option{-gnato}, then it is equivalent to -@option{-gnato11}, +@option{^-gnato11^/OVERFLOW_CHECKS=11^}, causing all intermediate overflows to be handled in strict mode. This switch also causes arithmetic overflow checking to be performed @@ -7059,8 +7059,7 @@ with the use of @option{-gnato} in previous versions of GNAT. @findex Machine_Overflows Note that the @option{-gnato??} switch does not affect the code generated -for any floating-point operations; it applies only to integer -semantics. +for any floating-point operations; it applies only to integer semantics. For floating-point, @value{EDITION} has the @code{Machine_Overflows} attribute set to @code{False} and the normal mode of operation is to generate IEEE NaN and infinite values on overflow or invalid operations @@ -7074,13 +7073,13 @@ subscript), or a wild jump (from an out of range case value). Overflow checking is also quite expensive in time and space, since in general it requires the use of double length arithmetic. -Note again that the default is @option{-gnato00}, so overflow checking is -not performed in default mode. This means that out of the box, with the -default settings, @value{EDITION} does not do all the checks expected from the -language description in the Ada Reference Manual. If you want all constraint -checks to be performed, as described in this Manual, then you must -explicitly use the @option{-gnato??} switch either on the @command{gnatmake} or -@command{gcc} command. +Note again that the default is @option{^-gnato00^/OVERFLOW_CHECKS=00^}, +so overflow checking is not performed in default mode. This means that out of +the box, with the default settings, @value{EDITION} does not do all the checks +expected from the language description in the Ada Reference Manual. +If you want all constraint checks to be performed, as described in this Manual, +then you must explicitly use the @option{-gnato??} +switch either on the @command{gnatmake} or @command{gcc} command. @item -gnatE @cindex @option{-gnatE} (@command{gcc}) @@ -18165,7 +18164,7 @@ the generated body sample to @var{n}. The default indentation is 3. @item ^-gnatyo^/ORDERED_SUBPROGRAMS^ -@cindex @option{^-gnato^/ORDERED_SUBPROGRAMS^} (@command{gnatstub}) +@cindex @option{^-gnatyo^/ORDERED_SUBPROGRAMS^} (@command{gnatstub}) Order local bodies alphabetically. (By default local bodies are ordered in the same way as the corresponding local specs in the argument spec file.) @@ -25962,10 +25961,11 @@ eliminate intermediate overflows (@code{ELIMINATED}) As with the pragma, if only one digit appears then it applies to all cases; if two digits are given, then the first applies outside assertions, and the second within assertions. Thus the equivalent -of the example pragma above would be @option{-gnato23}. +of the example pragma above would be +@option{^-gnato23^/OVERFLOW_CHECKS=23^}. If no digits follow the @option{-gnato}, then it is equivalent to -@option{-gnato11}, +@option{^-gnato11^/OVERFLOW_CHECKS=11^}, causing all intermediate operations to be computed using the base type (@code{STRICT} mode). diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index 6d33aaa..e2d6b84 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -369,12 +369,12 @@ package body Makeutl is Status : Boolean; -- For call to Close - Iter : Source_Iterator := - For_Each_Source - (In_Tree => Project_Tree, - Language => Name_Ada, - Encapsulated_Libs => False, - Locally_Removed => False); + Iter : Source_Iterator := For_Each_Source + (In_Tree => Project_Tree, + Language => Name_Ada, + Encapsulated_Libs => False, + Locally_Removed => False); + Source : Prj.Source_Id; begin @@ -431,13 +431,14 @@ package body Makeutl is -- found. if ALI_Name /= No_File then + -- Look in the project and the projects that are extending it -- to find the real ALI file. declare - ALI : constant String := Get_Name_String (ALI_Name); + ALI : constant String := Get_Name_String (ALI_Name); + ALI_Path : Name_Id := No_Name; - ALI_Path : Name_Id := No_Name; begin loop -- For library projects, use the library ALI directory, @@ -462,6 +463,7 @@ package body Makeutl is end loop; if ALI_Path /= No_Name then + -- First line is the unit name Get_Name_String (ALI_Unit); @@ -475,7 +477,7 @@ package body Makeutl is exit when not OK; - -- Second line it the ALI file name + -- Second line is the ALI file name Get_Name_String (ALI_Name); Add_Char_To_Name_Buffer (ASCII.LF); @@ -488,7 +490,7 @@ package body Makeutl is exit when not OK; - -- Third line it the ALI path name + -- Third line is the ALI path name Get_Name_String (ALI_Path); Add_Char_To_Name_Buffer (ASCII.LF); @@ -576,8 +578,9 @@ package body Makeutl is if Sw'Length >= 3 and then (Sw (2) = 'I' or else (not For_Gnatbind - and then (Sw (2) = 'L' - or else Sw (2) = 'A'))) + and then (Sw (2) = 'L' + or else + Sw (2) = 'A'))) then Start := 3; @@ -592,7 +595,7 @@ package body Makeutl is or else Sw (2 .. 3) = "aI" or else - (For_Gnatbind and then Sw (2 .. 3) = "A=")) + (For_Gnatbind and then Sw (2 .. 3) = "A=")) then Start := 4; diff --git a/gcc/ada/s-osprim-mingw.adb b/gcc/ada/s-osprim-mingw.adb index 874b1cb..a2c4664 100644 --- a/gcc/ada/s-osprim-mingw.adb +++ b/gcc/ada/s-osprim-mingw.adb @@ -68,17 +68,17 @@ package body System.OS_Primitives is type Clock_Data_Access is access all Clock_Data; - -- Two base clock buffers. This is used to be able to update a buffer - -- while the other buffer is read. The point is that we do not want to - -- use a lock inside the Clock routine for performance reasons. We still - -- use a lock in the Get_Base_Time which is called very rarely. Current - -- is a pointer, the pragma Atomic is there to ensure that the value can - -- be set or read atomically. That's it, when Get_Base_Time has updated - -- a buffer the switch to the new value is done by changing Current - -- pointer. + -- Two base clock buffers. This is used to be able to update a buffer while + -- the other buffer is read. The point is that we do not want to use a lock + -- inside the Clock routine for performance reasons. We still use a lock + -- in the Get_Base_Time which is called very rarely. Current is a pointer, + -- the pragma Atomic is there to ensure that the value can be set or read + -- atomically. That's it, when Get_Base_Time has updated a buffer the + -- switch to the new value is done by changing Current pointer. First, Second : aliased Clock_Data; - Current : Clock_Data_Access := First'Access; + + Current : Clock_Data_Access := First'Access; pragma Atomic (Current); -- The following signature is to detect change on the base clock data @@ -177,9 +177,11 @@ package body System.OS_Primitives is epoch_1970 : constant := 16#19D_B1DE_D53E_8000#; -- win32 UTC epoch system_time_ns : constant := 100; -- 100 ns per tick Sec_Unit : constant := 10#1#E9; - Max_Elapsed : constant LARGE_INTEGER := + + Max_Elapsed : constant LARGE_INTEGER := LARGE_INTEGER (Tick_Frequency / 100_000); -- Look for a precision of 0.01 ms + Sig : constant Signature_Type := Signature; Loc_Ticks, Ctrl_Ticks : aliased LARGE_INTEGER; @@ -269,13 +271,14 @@ package body System.OS_Primitives is end if; end loop; - New_Data.Base_Clock := Duration - (Long_Long_Float ((New_Data.Base_Time - epoch_1970) * system_time_ns) / - Long_Long_Float (Sec_Unit)); + New_Data.Base_Clock := + Duration + (Long_Long_Float + ((New_Data.Base_Time - epoch_1970) * system_time_ns) / + Long_Long_Float (Sec_Unit)); -- At this point all the base values have been set into the new data - -- record. We just change the pointer (atomic operation) to this new - -- values. + -- record. Change the pointer (atomic operation) to these new values. Current := New_Data; Data := New_Data.all; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 2346b10..4c68109 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -8347,7 +8347,6 @@ package body Sem_Ch3 is and then Present (Full_View (T)) then Analyze_And_Resolve (Expr, BDT, Suppress => Overflow_Check); - else Analyze_And_Resolve (Expr, BDT); end if; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 32d49cc..9ff423b 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -2821,13 +2821,13 @@ package body Sem_Ch8 is and then Entity (Prefix (Nam)) = Current_Scope and then Chars (Selector_Name (Nam)) = Chars (New_S) then - if Overriding_Renamings then - null; + -- This is an error, but we overlook the error and accept the + -- renaming if the special Overriding_Renamings mode is in effect. - else + if not Overriding_Renamings then Error_Msg_NE - ("implicit operation& is not visible (RM 8.3 (15))", - Nam, Old_S); + ("implicit operation& is not visible (RM 8.3 (15))", + Nam, Old_S); end if; end if; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index ab7f3c9..0ad0a41 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -1932,20 +1932,17 @@ package body Sem_Eval is Set_Is_Static_Expression (N, Stat); - if Stat then + -- If left operand is the empty string, the result is the + -- right operand, including its bounds if anomalous. - -- If left operand is the empty string, the result is the - -- right operand, including its bounds if anomalous. - - if Left_Len = 0 - and then Is_Array_Type (Etype (Right)) - and then Etype (Right) /= Any_String - then - Set_Etype (N, Etype (Right)); - end if; - - Fold_Str (N, Folded_Val, Static => True); + if Left_Len = 0 + and then Is_Array_Type (Etype (Right)) + and then Etype (Right) /= Any_String + then + Set_Etype (N, Etype (Right)); end if; + + Fold_Str (N, Folded_Val, Static => Stat); end; end Eval_Concatenation; @@ -3411,11 +3408,12 @@ package body Sem_Eval is -- is too long, or it is null, and the lower bound is type'First. In -- either case it is the upper bound that is out of range of the index -- type. - if Ada_Version >= Ada_95 then if Root_Type (Bas) = Standard_String or else Root_Type (Bas) = Standard_Wide_String + or else + Root_Type (Bas) = Standard_Wide_Wide_String then Xtp := Standard_Positive; else @@ -3428,24 +3426,54 @@ package body Sem_Eval is Lo := Type_Low_Bound (Etype (First_Index (Typ))); end if; + -- Check for string too long + Len := String_Length (Strval (N)); if UI_From_Int (Len) > String_Type_Len (Bas) then - Apply_Compile_Time_Constraint_Error - (N, "string literal too long for}", CE_Length_Check_Failed, - Ent => Bas, - Typ => First_Subtype (Bas)); + + -- Issue message. Note that this message is a warning if the + -- string literal is not marked as static (happens in some cases + -- of folding strings known at compile time, but not static). + -- Furthermore in such cases, we reword the message, since there + -- is no string literal in the source program! + + if Is_Static_Expression (N) then + Apply_Compile_Time_Constraint_Error + (N, "string literal too long for}", CE_Length_Check_Failed, + Ent => Bas, + Typ => First_Subtype (Bas)); + else + Apply_Compile_Time_Constraint_Error + (N, "string value too long for}", CE_Length_Check_Failed, + Ent => Bas, + Typ => First_Subtype (Bas), + Warn => True); + end if; + + -- Test for null string not allowed elsif Len = 0 and then not Is_Generic_Type (Xtp) and then Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp))) then - Apply_Compile_Time_Constraint_Error - (N, "null string literal not allowed for}", - CE_Length_Check_Failed, - Ent => Bas, - Typ => First_Subtype (Bas)); + -- Same specialization of message + + if Is_Static_Expression (N) then + Apply_Compile_Time_Constraint_Error + (N, "null string literal not allowed for}", + CE_Length_Check_Failed, + Ent => Bas, + Typ => First_Subtype (Bas)); + else + Apply_Compile_Time_Constraint_Error + (N, "null string value not allowed for}", + CE_Length_Check_Failed, + Ent => Bas, + Typ => First_Subtype (Bas), + Warn => True); + end if; end if; end if; end Eval_String_Literal; @@ -4091,7 +4119,7 @@ package body Sem_Eval is -- Note that we have to reset Is_Static_Expression both after the -- analyze step (because Resolve will evaluate the literal, which -- will cause semantic errors if it is marked as static), and after - -- the Resolve step (since Resolve in some cases sets this flag). + -- the Resolve step (since Resolve in some cases resets this flag). Analyze (N); Set_Is_Static_Expression (N, Static); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 32b5130..e60573e 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -5256,7 +5256,7 @@ package body Sem_Prag is elsif not Effective and then Warn_On_Redundant_Constructs - and then not (Status = Suppressed or Suppress_All_Inlining) + and then not (Status = Suppressed or else Suppress_All_Inlining) then if Inlining_Not_Possible (Subp) then Error_Msg_NE @@ -12434,12 +12434,14 @@ package body Sem_Prag is GNAT_Pragma; Check_At_Least_N_Arguments (1); Check_No_Identifiers; + Hint := First (Pragma_Argument_Associations (N)); while Present (Hint) loop Check_Arg_Is_One_Of (Hint, Name_No_Unroll, Name_Unroll, Name_No_Vector, Name_Vector); Next (Hint); end loop; + Check_Loop_Pragma_Placement; end Loop_Optimize; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index ae6fe60..2e05690 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -12009,7 +12009,7 @@ package body Sem_Util is function Is_Interface_Conversion (N : Node_Id) return Boolean; -- Determine whether N is a construct of the form -- Some_Type (Operand._tag'Address) - -- This construct appears in the context of dispatching calls + -- This construct appears in the context of dispatching calls. function Reference_To (Obj : Node_Id) return Node_Id; -- An explicit dereference is created when removing side-effects from diff --git a/gcc/ada/ug_words b/gcc/ada/ug_words index 77a36ca..d450164 100644 --- a/gcc/ada/ug_words +++ b/gcc/ada/ug_words @@ -94,6 +94,7 @@ gcc -c ^ GNAT COMPILE -gnatn2 ^ /INLINE=PRAGMA_LEVEL_2 -gnatN ^ /INLINE=FULL -gnato ^ /CHECKS=OVERFLOW +-gnato? ^ /OVERFLOW_CHECKS=? -gnato?? ^ /OVERFLOW_CHECKS=?? -gnatp ^ /CHECKS=SUPPRESS_ALL -gnat-p ^ /CHECKS=UNSUPPRESS_ALL diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 08a41c2..b69b34a 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -584,8 +584,8 @@ begin -- Line for -gnatW switch - Write_Switch_Char ("W"); - Write_Str ("Wide character encoding method ("); + Write_Switch_Char ("W?"); + Write_Str ("Wide character encoding method (?="); for J in WC_Encoding_Method loop Write_Char (WC_Encoding_Letters (J)); -- 2.7.4