+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,
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;
-- 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
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);
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);
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));
-- 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
-- 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)
-- 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)
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;
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);
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);
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);
* Pragma Profile::
* Pragma Profile_Warnings::
* Pragma Propagate_Exceptions::
+* Pragma Provide_Shift_Operators::
* Pragma Psect_Object::
* Pragma Pure_05::
* Pragma Pure_12::
* Pragma Profile::
* Pragma Profile_Warnings::
* Pragma Propagate_Exceptions::
+* Pragma Provide_Shift_Operators::
* Pragma Psect_Object::
* Pragma Pure_05::
* Pragma Pure_12::
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
@smallexample @c ada
function Shift_Left
(Value : T;
- Amount : Natural)
- return T;
+ Amount : Natural) return T;
@end smallexample
@noindent
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
* Elaboration for Dispatching Calls::
* Summary of Procedures for Elaboration Control::
* Other Elaboration Order Considerations::
+* Determining the Chosen Elaboration Order::
@end menu
@noindent
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
-- --
------------------------------------------------------------------------------
+pragma Compiler_Unit_Warning;
+
package Interfaces is
pragma Pure;
Pragma_Profile |
Pragma_Profile_Warnings |
Pragma_Propagate_Exceptions |
+ Pragma_Provide_Shift_Operators |
Pragma_Psect_Object |
Pragma_Pure |
Pragma_Pure_05 |
-- 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 (
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
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
end;
end if;
end;
+
+ <<Continue>>
+ null;
end loop;
end Validate_Unchecked_Conversions;
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.
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
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));
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
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;
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.
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,
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
("first argument of shift must match return type", Ptyp1, N);
return;
end if;
+
+ Set_Has_Shift_Operator (Base_Type (Typ1));
end Check_Shift;
------------
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;
-- 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;
"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 --
------------------
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,
-- 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
-- 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 + $;
Pragma_Preelaborate,
Pragma_Preelaborate_05,
Pragma_Pre_Class,
+ Pragma_Provide_Shift_Operators,
Pragma_Psect_Object,
Pragma_Pure,
Pragma_Pure_05,
Print_Node_Subtree (Cunit (Main_Unit));
Write_Eol;
end if;
-
end Tree_Dump;
-----------------
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);
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);
-- 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))
-- 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
projects / thirdparty / gcc.git / commitdiff
