OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2014-02-25  Robert Dewar  <dewar@adacore.com>

	* 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  <charlet@adacore.com>

	* usage.adb: Minor: fix typo.

From-SVN: r208138
This commit is contained in:
Arnaud Charlet 2014-02-25 16:18:38 +01:00
parent 0355e3ebbe
commit 4c51ff88f2
16 changed files with 493 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
gcc/ada/ChangeLog
View File

@ -1,3 +1,34 @@
2014-02-25 Robert Dewar <dewar@adacore.com>
* 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 <charlet@adacore.com>
* usage.adb: Minor: fix typo.
2014-02-25 Robert Dewar <dewar@adacore.com>
* lib.ads, s-bitops.adb, s-bitops.ads, s-conca5.adb, gnat_rm.texi,

8
gcc/ada/checks.adb
View File

@ -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;

15
gcc/ada/einfo.adb
View File

@ -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));

10
gcc/ada/einfo.ads
View File

@ -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);

28
gcc/ada/gnat_rm.texi
View File

@ -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

140
gcc/ada/gnat_ugn.texi
View File

@ -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

2
gcc/ada/interfac.ads
View File

@ -33,6 +33,8 @@
-- --
------------------------------------------------------------------------------
pragma Compiler_Unit_Warning;
package Interfaces is
pragma Pure;

1
gcc/ada/par-prag.adb
View File

@ -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 |

30
gcc/ada/sem_ch13.adb
View File

@ -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;
<<Continue>>
null;
end loop;
end Validate_Unchecked_Conversions;

7
gcc/ada/sem_ch3.adb
View File

@ -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

97
gcc/ada/sem_ch5.adb
View File

@ -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;

22
gcc/ada/sem_intr.adb
View File

@ -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;
------------

121
gcc/ada/sem_prag.adb
View File

@ -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,

3
gcc/ada/snames.ads-tmpl
View File

@ -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,

27
gcc/ada/treepr.adb
View File

@ -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))

2
gcc/ada/usage.adb
View File

@ -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