From: Arnaud Charlet Date: Tue, 25 Feb 2014 15:18:38 +0000 (+0100) Subject: [multiple changes] X-Git-Tag: releases/gcc-4.9.0~683 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=4c51ff88f2748e7f59d69d2b99c6749f4ec308c7;p=thirdparty%2Fgcc.git [multiple changes] 2014-02-25 Robert Dewar * einfo.ads, einfo.adb (Has_Shift_Operator): New flag. * gnat_rm.texi: Document pragma Provide_Shift_Operators. * interfac.ads: Minor code reorganization (add pragma Compiler_Unit_Warning). * par-prag.adb: Add dummy entry for Provide_Shift_Operators. * sem_ch3.adb (Build_Derived_Numeric_Type): Copy Has_Shift_Operator flag. * sem_intr.adb (Check_Intrinsic_Subprogram): Make sure Check_Shift is always called (Check_Shift): Set Has_Shift_Operator. * sem_prag.adb: Implement pragma Provide_Shift_Operators. * snames.ads-tmpl: Add entries for pragma Provide_Shift_Operators Add entry for Name_Amount. * checks.adb (Selected_Range_Checks): When checking for a null range, make sure we use the base type, and not the subtype for deciding a range is null. * sem_ch5.adb (Analyze_Loop_Parameter_Specification): Check for suspicious loop bound which is outside the range of the loop subtype. * gnat_ugn.texi: Add documentation section "Determining the Chosen Elaboration Order" * sem_ch13.adb (UC_Entry): Add field Act_Unit (Validate_Unchecked_Conversion): Store Act_Unit (Validate_Unchecked_Conversions): Test Warnings_Off in Act_Unit * treepr.adb: Minor reformatting. 2014-02-25 Arnaud Charlet * usage.adb: Minor: fix typo. From-SVN: r208138 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index bfd1657fe778..91cf5aeefee1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,34 @@ +2014-02-25 Robert Dewar + + * einfo.ads, einfo.adb (Has_Shift_Operator): New flag. + * gnat_rm.texi: Document pragma Provide_Shift_Operators. + * interfac.ads: Minor code reorganization (add pragma + Compiler_Unit_Warning). + * par-prag.adb: Add dummy entry for Provide_Shift_Operators. + * sem_ch3.adb (Build_Derived_Numeric_Type): Copy + Has_Shift_Operator flag. + * sem_intr.adb (Check_Intrinsic_Subprogram): Make sure + Check_Shift is always called (Check_Shift): Set Has_Shift_Operator. + * sem_prag.adb: Implement pragma Provide_Shift_Operators. + * snames.ads-tmpl: Add entries for pragma Provide_Shift_Operators + Add entry for Name_Amount. + * checks.adb (Selected_Range_Checks): When checking for a null + range, make sure we use the base type, and not the subtype for + deciding a range is null. + * sem_ch5.adb (Analyze_Loop_Parameter_Specification): Check + for suspicious loop bound which is outside the range of the + loop subtype. + * gnat_ugn.texi: Add documentation section "Determining the + Chosen Elaboration Order" + * sem_ch13.adb (UC_Entry): Add field Act_Unit + (Validate_Unchecked_Conversion): Store Act_Unit + (Validate_Unchecked_Conversions): Test Warnings_Off in Act_Unit + * treepr.adb: Minor reformatting. + +2014-02-25 Arnaud Charlet + + * usage.adb: Minor: fix typo. + 2014-02-25 Robert Dewar * lib.ads, s-bitops.adb, s-bitops.ads, s-conca5.adb, gnat_rm.texi, diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index ad4b5b7bb9a2..75be5b270679 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -9157,8 +9157,12 @@ package body Checks is Make_And_Then (Loc, Left_Opnd => Make_Op_Ge (Loc, - Left_Opnd => Duplicate_Subexpr_No_Checks (HB), - Right_Opnd => Duplicate_Subexpr_No_Checks (LB)), + Left_Opnd => + Convert_To (Base_Type (Etype (HB)), + Duplicate_Subexpr_No_Checks (HB)), + Right_Opnd => + Convert_To (Base_Type (Etype (LB)), + Duplicate_Subexpr_No_Checks (LB))), Right_Opnd => Cond); end; end if; diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 01ec45a457d9..076cf7bf057e 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -557,12 +557,12 @@ package body Einfo is -- Is_Discriminant_Check_Function Flag264 -- SPARK_Pragma_Inherited Flag265 -- SPARK_Aux_Pragma_Inherited Flag266 + -- Has_Shift_Operator Flag267 -- (unused) Flag1 -- (unused) Flag2 -- (unused) Flag3 - -- (unused) Flag267 -- (unused) Flag268 -- (unused) Flag269 -- (unused) Flag270 @@ -1667,6 +1667,12 @@ package body Einfo is return Flag143 (Id); end Has_Recursive_Call; + function Has_Shift_Operator (Id : E) return B is + begin + pragma Assert (Is_Integer_Type (Id)); + return Flag267 (Base_Type (Id)); + end Has_Shift_Operator; + function Has_Size_Clause (Id : E) return B is begin return Flag29 (Id); @@ -4372,6 +4378,12 @@ package body Einfo is Set_Flag143 (Id, V); end Set_Has_Recursive_Call; + procedure Set_Has_Shift_Operator (Id : E; V : B := True) is + begin + pragma Assert (Is_Integer_Type (Id) and then Is_Base_Type (Id)); + Set_Flag267 (Id, V); + end Set_Has_Shift_Operator; + procedure Set_Has_Size_Clause (Id : E; V : B := True) is begin Set_Flag29 (Id, V); @@ -8203,6 +8215,7 @@ package body Einfo is W ("Has_RACW", Flag214 (Id)); W ("Has_Record_Rep_Clause", Flag65 (Id)); W ("Has_Recursive_Call", Flag143 (Id)); + W ("Has_Shift_Operator", Flag267 (Id)); W ("Has_Size_Clause", Flag29 (Id)); W ("Has_Small_Clause", Flag67 (Id)); W ("Has_Specified_Layout", Flag100 (Id)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index a9106b2e75b3..91f59b42309a 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1826,6 +1826,10 @@ package Einfo is -- is detected while analyzing the body. Used to activate some error -- checks for infinite recursion. +-- Has_Shift_Operator (Flag267) [base type only] +-- Defined in integer types. Set in the base type of an integer type for +-- which at least one of the shift operators is defined. + -- Has_Size_Clause (Flag29) -- Defined in entities for types and objects. Set if a size clause is -- defined for the entity. Used to prevent multiple Size clauses for a @@ -5644,6 +5648,7 @@ package Einfo is -- Static_Predicate (List25) -- Non_Binary_Modulus (Flag58) (base type only) -- Has_Biased_Representation (Flag139) + -- Has_Shift_Operator (Flag267) (base type only) -- Type_Low_Bound (synth) -- Type_High_Bound (synth) -- (plus type attributes) @@ -5940,6 +5945,7 @@ package Einfo is -- Scalar_Range (Node20) -- Static_Predicate (List25) -- Has_Biased_Representation (Flag139) + -- Has_Shift_Operator (Flag267) (base type only) -- Type_Low_Bound (synth) -- Type_High_Bound (synth) -- (plus type attributes) @@ -6465,6 +6471,7 @@ package Einfo is function Has_RACW (Id : E) return B; function Has_Record_Rep_Clause (Id : E) return B; function Has_Recursive_Call (Id : E) return B; + function Has_Shift_Operator (Id : E) return B; function Has_Size_Clause (Id : E) return B; function Has_Small_Clause (Id : E) return B; function Has_Specified_Layout (Id : E) return B; @@ -7088,6 +7095,7 @@ package Einfo is procedure Set_Has_RACW (Id : E; V : B := True); procedure Set_Has_Record_Rep_Clause (Id : E; V : B := True); procedure Set_Has_Recursive_Call (Id : E; V : B := True); + procedure Set_Has_Shift_Operator (Id : E; V : B := True); procedure Set_Has_Size_Clause (Id : E; V : B := True); procedure Set_Has_Small_Clause (Id : E; V : B := True); procedure Set_Has_Specified_Layout (Id : E; V : B := True); @@ -7825,6 +7833,7 @@ package Einfo is pragma Inline (Has_RACW); pragma Inline (Has_Record_Rep_Clause); pragma Inline (Has_Recursive_Call); + pragma Inline (Has_Shift_Operator); pragma Inline (Has_Size_Clause); pragma Inline (Has_Small_Clause); pragma Inline (Has_Specified_Layout); @@ -8296,6 +8305,7 @@ package Einfo is pragma Inline (Set_Has_RACW); pragma Inline (Set_Has_Record_Rep_Clause); pragma Inline (Set_Has_Recursive_Call); + pragma Inline (Set_Has_Shift_Operator); pragma Inline (Set_Has_Size_Clause); pragma Inline (Set_Has_Small_Clause); pragma Inline (Set_Has_Specified_Layout); diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 5a3d7629c352..2090c62a02c3 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -224,6 +224,7 @@ Implementation Defined Pragmas * Pragma Profile:: * Pragma Profile_Warnings:: * Pragma Propagate_Exceptions:: +* Pragma Provide_Shift_Operators:: * Pragma Psect_Object:: * Pragma Pure_05:: * Pragma Pure_12:: @@ -1056,6 +1057,7 @@ consideration, the use of these pragmas should be minimized. * Pragma Profile:: * Pragma Profile_Warnings:: * Pragma Propagate_Exceptions:: +* Pragma Provide_Shift_Operators:: * Pragma Psect_Object:: * Pragma Pure_05:: * Pragma Pure_12:: @@ -5852,6 +5854,25 @@ It is retained for compatibility purposes. It used to be used in connection with optimization of a now-obsolete mechanism for implementation of exceptions. +@node Pragma Provide_Shift_Operators +@unnumberedsec Pragma Provide_Shift_Operators +@cindex Shift operators +@findex Provide_Shift_Operators +@noindent +Syntax: + +@smallexample @c ada +pragma Provide_Shift_Operators (integer_first_subtype_LOCAL_NAME); +@end smallexample + +@noindent +This pragma can be applied to a first subtype local name that specifies +either an unsigned or signed type. It has the effect of providing the +five shift operators (Shift_Left, Shift_Right, Shift_Right_Arithmetic, +Rotate_Left and Rotate_Right) for the given type. It is equivalent to +including the function declarations for these five operators, together +with the pragma Import (Intrinsic, ...) statements. + @node Pragma Psect_Object @unnumberedsec Pragma Psect_Object @findex Psect_Object @@ -13685,8 +13706,7 @@ type (signed or modular), as in this example: @smallexample @c ada function Shift_Left (Value : T; - Amount : Natural) - return T; + Amount : Natural) return T; @end smallexample @noindent @@ -13699,6 +13719,10 @@ The result type must be the same as the type of @code{Value}. The shift amount must be Natural. The formal parameter names can be anything. +A more convenient way of providing these shift operators is to use +the Provide_Shift_Operators pragma, which provides the function declarations +and corresponding pragma Import's for all five shift functions. + @node Source_Location @section Source_Location @cindex Source_Location diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 6fc86ab524a8..54a0a5c01e38 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -25049,6 +25049,7 @@ elaboration code in your own application). * Elaboration for Dispatching Calls:: * Summary of Procedures for Elaboration Control:: * Other Elaboration Order Considerations:: +* Determining the Chosen Elaboration Order:: @end menu @noindent @@ -26891,6 +26892,145 @@ difference, by looking at the two elaboration orders that are chosen, and figuring out which is correct, and then adding the necessary @code{Elaborate} or @code{Elaborate_All} pragmas to ensure the desired order. +@node Determining the Chosen Elaboration Order +@section Determining the Chosen Elaboration Order +@noindent + +To see the elaboration order that the binder chooses, you can look at +the last part of the b~xxx.adb binder output file. Here is an example: + +@smallexample @c ada +System.Soft_Links'Elab_Body; +E14 := True; +System.Secondary_Stack'Elab_Body; +E18 := True; +System.Exception_Table'Elab_Body; +E24 := True; +Ada.Io_Exceptions'Elab_Spec; +E67 := True; +Ada.Tags'Elab_Spec; +Ada.Streams'Elab_Spec; +E43 := True; +Interfaces.C'Elab_Spec; +E69 := True; +System.Finalization_Root'Elab_Spec; +E60 := True; +System.Os_Lib'Elab_Body; +E71 := True; +System.Finalization_Implementation'Elab_Spec; +System.Finalization_Implementation'Elab_Body; +E62 := True; +Ada.Finalization'Elab_Spec; +E58 := True; +Ada.Finalization.List_Controller'Elab_Spec; +E76 := True; +System.File_Control_Block'Elab_Spec; +E74 := True; +System.File_Io'Elab_Body; +E56 := True; +Ada.Tags'Elab_Body; +E45 := True; +Ada.Text_Io'Elab_Spec; +Ada.Text_Io'Elab_Body; +E07 := True; +@end smallexample + +@noindent +Here Elab_Spec elaborates the spec +and Elab_Body elaborates the body. The assignments to the Exx flags +flag that the corresponding body is now elaborated. + +You can also ask the binder to generate a more +readable list of the elaboration order using the +@code{-l} switch when invoking the binder. Here is +an example of the output generated by this switch: + +@smallexample +ada (spec) +interfaces (spec) +system (spec) +system.case_util (spec) +system.case_util (body) +system.concat_2 (spec) +system.concat_2 (body) +system.concat_3 (spec) +system.concat_3 (body) +system.htable (spec) +system.parameters (spec) +system.parameters (body) +system.crtl (spec) +interfaces.c_streams (spec) +interfaces.c_streams (body) +system.restrictions (spec) +system.restrictions (body) +system.standard_library (spec) +system.exceptions (spec) +system.exceptions (body) +system.storage_elements (spec) +system.storage_elements (body) +system.secondary_stack (spec) +system.stack_checking (spec) +system.stack_checking (body) +system.string_hash (spec) +system.string_hash (body) +system.htable (body) +system.strings (spec) +system.strings (body) +system.traceback (spec) +system.traceback (body) +system.traceback_entries (spec) +system.traceback_entries (body) +ada.exceptions (spec) +ada.exceptions.last_chance_handler (spec) +system.soft_links (spec) +system.soft_links (body) +ada.exceptions.last_chance_handler (body) +system.secondary_stack (body) +system.exception_table (spec) +system.exception_table (body) +ada.io_exceptions (spec) +ada.tags (spec) +ada.streams (spec) +interfaces.c (spec) +interfaces.c (body) +system.finalization_root (spec) +system.finalization_root (body) +system.memory (spec) +system.memory (body) +system.standard_library (body) +system.os_lib (spec) +system.os_lib (body) +system.unsigned_types (spec) +system.stream_attributes (spec) +system.stream_attributes (body) +system.finalization_implementation (spec) +system.finalization_implementation (body) +ada.finalization (spec) +ada.finalization (body) +ada.finalization.list_controller (spec) +ada.finalization.list_controller (body) +system.file_control_block (spec) +system.file_io (spec) +system.file_io (body) +system.val_uns (spec) +system.val_util (spec) +system.val_util (body) +system.val_uns (body) +system.wch_con (spec) +system.wch_con (body) +system.wch_cnv (spec) +system.wch_jis (spec) +system.wch_jis (body) +system.wch_cnv (body) +system.wch_stw (spec) +system.wch_stw (body) +ada.tags (body) +ada.exceptions (body) +ada.text_io (spec) +ada.text_io (body) +text_io (spec) +gdbstr (body) +@end smallexample @c ********************************** @node Overflow Check Handling in GNAT diff --git a/gcc/ada/interfac.ads b/gcc/ada/interfac.ads index 57033a94ecaf..fe6bb0f6deaa 100644 --- a/gcc/ada/interfac.ads +++ b/gcc/ada/interfac.ads @@ -33,6 +33,8 @@ -- -- ------------------------------------------------------------------------------ +pragma Compiler_Unit_Warning; + package Interfaces is pragma Pure; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 5182d7c34d2c..14560ea59788 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1278,6 +1278,7 @@ begin Pragma_Profile | Pragma_Profile_Warnings | Pragma_Propagate_Exceptions | + Pragma_Provide_Shift_Operators | Pragma_Psect_Object | Pragma_Pure | Pragma_Pure_05 | diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index d8c71d778cbd..1f8d73f25196 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -199,9 +199,10 @@ package body Sem_Ch13 is -- already have modified all Sloc values if the -gnatD option is set. type UC_Entry is record - Eloc : Source_Ptr; -- node used for posting warnings - Source : Entity_Id; -- source type for unchecked conversion - Target : Entity_Id; -- target type for unchecked conversion + Eloc : Source_Ptr; -- node used for posting warnings + Source : Entity_Id; -- source type for unchecked conversion + Target : Entity_Id; -- target type for unchecked conversion + Act_Unit : Entity_Id; -- actual function instantiated end record; package Unchecked_Conversions is new Table.Table ( @@ -11700,9 +11701,10 @@ package body Sem_Ch13 is if Warn_On_Unchecked_Conversion then Unchecked_Conversions.Append - (New_Val => UC_Entry'(Eloc => Sloc (N), - Source => Source, - Target => Target)); + (New_Val => UC_Entry'(Eloc => Sloc (N), + Source => Source, + Target => Target, + Act_Unit => Act_Unit)); -- If both sizes are known statically now, then back end annotation -- is not required to do a proper check but if either size is not @@ -11757,14 +11759,21 @@ package body Sem_Ch13 is declare T : UC_Entry renames Unchecked_Conversions.Table (N); - Eloc : constant Source_Ptr := T.Eloc; - Source : constant Entity_Id := T.Source; - Target : constant Entity_Id := T.Target; + Eloc : constant Source_Ptr := T.Eloc; + Source : constant Entity_Id := T.Source; + Target : constant Entity_Id := T.Target; + Act_Unit : constant Entity_Id := T.Act_Unit; Source_Siz : Uint; Target_Siz : Uint; begin + -- Skip if function marked as warnings off + + if Warnings_Off (Act_Unit) then + goto Continue; + end if; + -- This validation check, which warns if we have unequal sizes for -- unchecked conversion, and thus potentially implementation -- dependent semantics, is one of the few occasions on which we @@ -11904,6 +11913,9 @@ package body Sem_Ch13 is end; end if; end; + + <> + null; end loop; end Validate_Unchecked_Conversions; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index e7c9167b460c..ad7d88033d70 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -6401,6 +6401,11 @@ package body Sem_Ch3 is end if; end if; + if Is_Integer_Type (Parent_Type) then + Set_Has_Shift_Operator + (Implicit_Base, Has_Shift_Operator (Parent_Type)); + end if; + -- The type of the bounds is that of the parent type, and they -- must be converted to the derived type. @@ -14807,7 +14812,7 @@ package body Sem_Ch3 is if Parent_Type = Any_Type or else Etype (Parent_Type) = Any_Type or else (Is_Class_Wide_Type (Parent_Type) - and then Etype (Parent_Type) = T) + and then Etype (Parent_Type) = T) then -- If Parent_Type is undefined or illegal, make new type into a -- subtype of Any_Type, and set a few attributes to prevent cascaded diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index b864433bbd84..1e7c4c2566ea 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2488,9 +2488,9 @@ package body Sem_Ch5 is or else Etype (Id) = Any_Type or else (Present (Etype (Id)) - and then Is_Itype (Etype (Id)) - and then Nkind (Parent (Loop_Nod)) = N_Expression_With_Actions - and then Nkind (Original_Node (Parent (Loop_Nod))) = + and then Is_Itype (Etype (Id)) + and then Nkind (Parent (Loop_Nod)) = N_Expression_With_Actions + and then Nkind (Original_Node (Parent (Loop_Nod))) = N_Quantified_Expression) then Set_Etype (Id, Etype (DS)); @@ -2517,19 +2517,33 @@ package body Sem_Ch5 is end; end if; - -- Check for null or possibly null range and issue warning. We suppress - -- such messages in generic templates and instances, because in practice - -- they tend to be dubious in these cases. The check applies as well to - -- rewritten array element loops where a null range may be detected - -- statically. + -- Case where we have a range or a subtype, get type bounds - if Nkind (DS) = N_Range then + if Nkind_In (DS, N_Range, N_Subtype_Indication) + and then not Error_Posted (DS) + and then Etype (DS) /= Any_Type + and then Is_Discrete_Type (Etype (DS)) + then declare - L : constant Node_Id := Low_Bound (DS); - H : constant Node_Id := High_Bound (DS); + L : Node_Id; + H : Node_Id; begin - -- If range of loop is null, issue warning + if Nkind (DS) = N_Range then + L := Low_Bound (DS); + H := High_Bound (DS); + else + L := + Type_Low_Bound (Underlying_Type (Etype (Subtype_Mark (DS)))); + H := + Type_High_Bound (Underlying_Type (Etype (Subtype_Mark (DS)))); + end if; + + -- Check for null or possibly null range and issue warning. We + -- suppress such messages in generic templates and instances, + -- because in practice they tend to be dubious in these cases. The + -- check applies as well to rewritten array element loops where a + -- null range may be detected statically. if Compile_Time_Compare (L, H, Assume_Valid => True) = GT then @@ -2610,6 +2624,65 @@ package body Sem_Ch5 is Error_Msg_N ("\??bounds may be wrong way round", DS); end if; end if; + + -- Check if either bound is known to be outside the range of the + -- loop parameter type, this is e.g. the case of a loop from + -- 20..X where the type is 1..19. + + -- Such a loop is dubious since either it raises CE or it executes + -- zero times, and that cannot be useful! + + if Etype (DS) /= Any_Type + and then not Error_Posted (DS) + and then Nkind (DS) = N_Subtype_Indication + and then Nkind (Constraint (DS)) = N_Range_Constraint + then + declare + LLo : constant Node_Id := + Low_Bound (Range_Expression (Constraint (DS))); + LHi : constant Node_Id := + High_Bound (Range_Expression (Constraint (DS))); + + Bad_Bound : Node_Id := Empty; + -- Suspicious loop bound + + begin + -- At this stage L, H are the bounds of the type, and LLo + -- Lhi are the low bound and high bound of the loop. + + if Compile_Time_Compare (LLo, L, Assume_Valid => True) = LT + or else + Compile_Time_Compare (LLo, H, Assume_Valid => True) = GT + then + Bad_Bound := LLo; + end if; + + if Compile_Time_Compare (LHi, L, Assume_Valid => True) = LT + or else + Compile_Time_Compare (LHi, H, Assume_Valid => True) = GT + then + Bad_Bound := LHi; + end if; + + if Present (Bad_Bound) then + Error_Msg_N + ("suspicious loop bound out of range of " + & "loop subtype??", Bad_Bound); + Error_Msg_N + ("\loop executes zero times or raises " + & "Constraint_Error??", Bad_Bound); + end if; + end; + end if; + + -- This declare block is about warnings, if we get an exception while + -- testing for warnings, we simply abandon the attempt silently. This + -- most likely occurs as the result of a previous error, but might + -- just be an obscure case we have missed. In either case, not giving + -- the warning is perfectly acceptable. + + exception + when others => null; end; end if; diff --git a/gcc/ada/sem_intr.adb b/gcc/ada/sem_intr.adb index 4682d250d814..5fb7442a82c8 100644 --- a/gcc/ada/sem_intr.adb +++ b/gcc/ada/sem_intr.adb @@ -328,6 +328,14 @@ package body Sem_Intr is then Errint ("unrecognized intrinsic subprogram", E, N); + -- Shift cases. We allow user specification of intrinsic shift operators + -- for any numeric types. + + elsif Nam_In (Nam, Name_Rotate_Left, Name_Rotate_Right, Name_Shift_Left, + Name_Shift_Right, Name_Shift_Right_Arithmetic) + then + Check_Shift (E, N); + -- We always allow intrinsic specifications in language defined units -- and in expanded code. We assume that the GNAT implementors know what -- they are doing, and do not write or generate junk use of intrinsic. @@ -339,13 +347,7 @@ package body Sem_Intr is then null; - -- Shift cases. We allow user specification of intrinsic shift - -- operators for any numeric types. - - elsif Nam_In (Nam, Name_Rotate_Left, Name_Rotate_Right, Name_Shift_Left, - Name_Shift_Right, Name_Shift_Right_Arithmetic) - then - Check_Shift (E, N); + -- Exception functions elsif Nam_In (Nam, Name_Exception_Information, Name_Exception_Message, @@ -353,9 +355,13 @@ package body Sem_Intr is then Check_Exception_Function (E, N); + -- Intrinsic operators + elsif Nkind (E) = N_Defining_Operator_Symbol then Check_Intrinsic_Operator (E, N); + -- Source_Location and navigation functions + elsif Nam_In (Nam, Name_File, Name_Line, Name_Source_Location, Name_Enclosing_Entity) then @@ -439,6 +445,8 @@ package body Sem_Intr is ("first argument of shift must match return type", Ptyp1, N); return; end if; + + Set_Has_Shift_Operator (Base_Type (Typ1)); end Check_Shift; ------------ diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index c7dd6343da21..d61c02bf90c2 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -14948,7 +14948,7 @@ package body Sem_Prag is elsif K = N_Object_Declaration or else (K = N_Component_Declaration - and then Original_Record_Component (E) = E) + and then Original_Record_Component (E) = E) then if Rep_Item_Too_Late (E, N) then return; @@ -15514,7 +15514,6 @@ package body Sem_Prag is -- Ada.Interrupts.Interrupt_ID. when Pragma_Interrupt_State => Interrupt_State : declare - Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID); -- This is the entity Ada.Interrupts.Interrupt_ID; @@ -18472,6 +18471,123 @@ package body Sem_Prag is "and has no effect?j?", N); end if; + ----------------------------- + -- Provide_Shift_Operators -- + ----------------------------- + + -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME); + + when Pragma_Provide_Shift_Operators => + Provide_Shift_Operators : declare + Ent : Entity_Id; + + procedure Declare_Shift_Operator (Nam : Name_Id); + -- Insert declaration and pragma Instrinsic for named shift op + + ---------------------------- + -- Declare_Shift_Operator -- + ---------------------------- + + procedure Declare_Shift_Operator (Nam : Name_Id) is + Func : Node_Id; + Import : Node_Id; + + begin + Func := + Make_Subprogram_Declaration (Loc, + Make_Function_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Chars => Nam), + + Result_Definition => + Make_Identifier (Loc, Chars => Chars (Ent)), + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Value), + Parameter_Type => + Make_Identifier (Loc, Chars => Chars (Ent))), + + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Amount), + Parameter_Type => + New_Occurrence_Of (Standard_Natural, Loc))))); + + Import := + Make_Pragma (Loc, + Pragma_Identifier => Make_Identifier (Loc, Name_Import), + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_Intrinsic)), + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Nam)))); + + Insert_After (N, Import); + Insert_After (N, Func); + end Declare_Shift_Operator; + + -- Start of processing for Provide_Shift_Operators + + begin + GNAT_Pragma; + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + + Arg1 := Get_Pragma_Arg (Arg1); + + -- We must have an entity name + + if not Is_Entity_Name (Arg1) then + Error_Pragma_Arg + ("pragma % must apply to integer first subtype", Arg1); + end if; + + -- If no Entity, means there was a prior error so ignore + + if Present (Entity (Arg1)) then + Ent := Entity (Arg1); + + -- Apply error checks + + if not Is_First_Subtype (Ent) then + Error_Pragma_Arg + ("cannot apply pragma %", + "\& is not a first subtype", + Arg1); + + elsif not Is_Integer_Type (Ent) then + Error_Pragma_Arg + ("cannot apply pragma %", + "\& is not an integer type", + Arg1); + + elsif Has_Shift_Operator (Ent) then + Error_Pragma_Arg + ("cannot apply pragma %", + "\& already has declared shift operators", + Arg1); + + elsif Is_Frozen (Ent) then + Error_Pragma_Arg + ("pragma % appears too late", + "\& is already frozen", + Arg1); + end if; + + -- Now declare the operators. We do this during analysis rather + -- than expansion, since we want the operators available if we + -- are operating in -gnatc or ASIS mode. + + Declare_Shift_Operator (Name_Rotate_Left); + Declare_Shift_Operator (Name_Rotate_Right); + Declare_Shift_Operator (Name_Shift_Left); + Declare_Shift_Operator (Name_Shift_Right); + Declare_Shift_Operator (Name_Shift_Right_Arithmetic); + end if; + end Provide_Shift_Operators; + ------------------ -- Psect_Object -- ------------------ @@ -25675,6 +25791,7 @@ package body Sem_Prag is Pragma_Profile => 0, Pragma_Profile_Warnings => 0, Pragma_Propagate_Exceptions => -1, + Pragma_Provide_Shift_Operators => -1, Pragma_Psect_Object => -1, Pragma_Pure => -1, Pragma_Pure_05 => -1, diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 173f73430b43..876ac04a4387 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -585,6 +585,7 @@ package Snames is -- correctly recognize and process Priority. Priority is a standard Ada 95 -- pragma. + Name_Provide_Shift_Operators : constant Name_Id := N + $; -- GNAT Name_Psect_Object : constant Name_Id := N + $; -- VMS Name_Pure : constant Name_Id := N + $; Name_Pure_05 : constant Name_Id := N + $; -- GNAT @@ -686,6 +687,7 @@ package Snames is -- Other special names used in processing pragmas + Name_Amount : constant Name_Id := N + $; Name_As_Is : constant Name_Id := N + $; Name_Assertion : constant Name_Id := N + $; Name_Assertions : constant Name_Id := N + $; @@ -1889,6 +1891,7 @@ package Snames is Pragma_Preelaborate, Pragma_Preelaborate_05, Pragma_Pre_Class, + Pragma_Provide_Shift_Operators, Pragma_Psect_Object, Pragma_Pure, Pragma_Pure_05, diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index 0bfc6e3dab34..0cce75f9aa2b 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -1701,7 +1701,6 @@ package body Treepr is Print_Node_Subtree (Cunit (Main_Unit)); Write_Eol; end if; - end Tree_Dump; ----------------- @@ -1956,13 +1955,13 @@ package body Treepr is then return; - -- Otherwise we can visit the list. Note that we don't bother - -- to do the parent test that we did for the node case, because - -- it just does not happen that lists are referenced more than - -- one place in the tree. We aren't counting on this being the - -- case to generate valid output, it is just that we don't need - -- in practice to worry about listing the list at a place that - -- is inconvenient. + -- Otherwise we can visit the list. Note that we don't bother to + -- do the parent test that we did for the node case, because it + -- just does not happen that lists are referenced more than one + -- place in the tree. We aren't counting on this being the case + -- to generate valid output, it is just that we don't need in + -- practice to worry about listing the list at a place that is + -- inconvenient. else Visit_List (List_Id (D), New_Prefix); @@ -2024,9 +2023,9 @@ package body Treepr is else if Serial_Number (Int (N)) < Next_Serial_Number then - -- Here we have already visited the node, but if it is in - -- a list, we still want to print the reference, so that - -- it is clear that it belongs to the list. + -- Here we have already visited the node, but if it is in a list, + -- we still want to print the reference, so that it is clear that + -- it belongs to the list. if Is_List_Member (N) then Print_Str (Prefix_Str); @@ -2109,9 +2108,9 @@ package body Treepr is -- indentations coming from this effect. -- To prevent this, what we do is to control references via - -- Next_Entity only from the first entity on a given scope - -- chain, and we keep them all at the same level. Of course - -- if an entity has already been referenced it is not printed. + -- Next_Entity only from the first entity on a given scope chain, + -- and we keep them all at the same level. Of course if an entity + -- has already been referenced it is not printed. if Present (Next_Entity (N)) and then Present (Scope (N)) diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index af8fd7793d85..0b50555c2466 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -211,7 +211,7 @@ begin -- Line for -gnatei switch Write_Switch_Char ("einn"); - Write_Line ("Set maximumum number of instantiations to nn"); + Write_Line ("Set maximum number of instantiations to nn"); -- Line for -gnateI switch