-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005, 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- --
Ptr : in out Natural)
is
begin
- if X.Num_Tracebacks <= 0 then
+ if X.Num_Tracebacks = 0 then
return;
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005, 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- --
exit when N = Right_Opnd (P)
and then Nkind (Left_Opnd (P)) = N_Op_Eq;
- -- And/And then case, left operand must be inequality test. Note that
- -- at this stage, the expander will have changed a/=b to not (a=b).
+ -- And/And then case, left operand must be inequality test
elsif K = N_Op_And or else K = N_And_Then then
exit when N = Right_Opnd (P)
- and then Nkind (Left_Opnd (P)) = N_Op_Not
- and then Nkind (Right_Opnd (Left_Opnd (P))) = N_Op_Eq;
+ and then Nkind (Left_Opnd (P)) = N_Op_Ne;
end if;
N := P;
function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
+ -- The complication in this routine is that if we are in the dynamic
+ -- model of elaboration, we also check All_Checks, since All_Checks
+ -- does not set Elaboration_Check explicitly.
+
if Present (E) then
if Kill_Elaboration_Checks (E) then
return True;
+
elsif Checks_May_Be_Suppressed (E) then
- return Is_Check_Suppressed (E, Elaboration_Check);
+ if Is_Check_Suppressed (E, Elaboration_Check) then
+ return True;
+ elsif Dynamic_Elaboration_Checks then
+ return Is_Check_Suppressed (E, All_Checks);
+ else
+ return False;
+ end if;
end if;
end if;
- return Scope_Suppress (Elaboration_Check);
+ if Scope_Suppress (Elaboration_Check) then
+ return True;
+ elsif Dynamic_Elaboration_Checks then
+ return Scope_Suppress (All_Checks);
+ else
+ return False;
+ end if;
end Elaboration_Checks_Suppressed;
---------------------------
then
return;
+ -- No check on a univeral real constant. The context will eventually
+ -- convert it to a machine number for some target type, or report an
+ -- illegality.
+
+ elsif Nkind (Expr) = N_Real_Literal
+ and then Etype (Expr) = Universal_Real
+ then
+ return;
+
-- An annoying special case. If this is an out parameter of a scalar
-- type, then the value is not going to be accessed, therefore it is
-- inappropriate to do any validity check at the call site.
then
return Expr_Known_Valid (Expression (Expr));
- -- The result of any function call or operator is always considered
- -- valid, since we assume the necessary checks are done by the call.
- -- For operators on floating-point operations, we must also check
- -- when the operation is the right-hand side of an assignment, or
- -- is an actual in a call.
+ -- The result of any operator is always considered valid, since we
+ -- assume the necessary checks are done by the operator. For operators
+ -- on floating-point operations, we must also check when the operation
+ -- is the right-hand side of an assignment, or is an actual in a call.
elsif
Nkind (Expr) in N_Binary_Op or else Nkind (Expr) in N_Unary_Op
return True;
end if;
- elsif Nkind (Expr) = N_Function_Call then
- return True;
-
-- For all other cases, we do not know the expression is valid
else
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005, 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- --
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Exp_VFpt; use Exp_VFpt;
+with Freeze; use Freeze;
with Hostparm; use Hostparm;
with Inline; use Inline;
with Nlists; use Nlists;
---------------------------------
procedure Expand_Allocator_Expression (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Exp : constant Node_Id := Expression (Expression (N));
- Indic : constant Node_Id := Subtype_Mark (Expression (N));
- PtrT : constant Entity_Id := Etype (N);
- T : constant Entity_Id := Entity (Indic);
- Flist : Node_Id;
- Node : Node_Id;
- Temp : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+ Exp : constant Node_Id := Expression (Expression (N));
+ Indic : constant Node_Id := Subtype_Mark (Expression (N));
+ PtrT : constant Entity_Id := Etype (N);
+ DesigT : constant Entity_Id := Designated_Type (PtrT);
+ T : constant Entity_Id := Entity (Indic);
+ Flist : Node_Id;
+ Node : Node_Id;
+ Temp : Entity_Id;
Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
-- body, so a run-time check is needed in general.
if Ada_Version >= Ada_05
- and then Is_Class_Wide_Type (Designated_Type (PtrT))
+ and then Is_Class_Wide_Type (DesigT)
and then not Scope_Suppress (Accessibility_Check)
and then
(Is_Class_Wide_Type (Etype (Exp))
end;
end if;
- if Controlled_Type (Designated_Type (PtrT))
+ if Controlled_Type (DesigT)
and then Controlled_Type (T)
then
declare
Rewrite (N, New_Reference_To (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
- elsif Is_Access_Type (Designated_Type (PtrT))
+ elsif Is_Access_Type (DesigT)
and then Nkind (Exp) = N_Allocator
and then Nkind (Expression (Exp)) /= N_Qualified_Expression
then
-- Apply constraint to designated subtype indication
Apply_Constraint_Check (Expression (Exp),
- Designated_Type (Designated_Type (PtrT)),
+ Designated_Type (DesigT),
No_Sliding => True);
if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
-- on the qualified expression does not allow sliding,
-- but this check does (a relaxation from Ada 83).
- if Is_Constrained (Designated_Type (PtrT))
+ if Is_Constrained (DesigT)
and then not Subtypes_Statically_Match
- (T, Designated_Type (PtrT))
+ (T, DesigT)
then
Apply_Constraint_Check
- (Exp, Designated_Type (PtrT), No_Sliding => False);
+ (Exp, DesigT, No_Sliding => False);
-- The nonsliding check should really be performed
-- (unconditionally) against the subtype of the
else
Apply_Constraint_Check
- (Exp, Designated_Type (PtrT), No_Sliding => True);
+ (Exp, DesigT, No_Sliding => True);
+ end if;
+
+ -- For an access to unconstrained packed array, GIGI needs
+ -- to see an expression with a constrained subtype in order
+ -- to compute the proper size for the allocator.
+
+ if Is_Array_Type (T)
+ and then not Is_Constrained (T)
+ and then Is_Packed (T)
+ then
+ declare
+ ConstrT : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('A'));
+ Internal_Exp : constant Node_Id := Relocate_Node (Exp);
+ begin
+ Insert_Action (Exp,
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => ConstrT,
+ Subtype_Indication =>
+ Make_Subtype_From_Expr (Exp, T)));
+ Freeze_Itype (ConstrT, Exp);
+ Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp));
+ end;
end if;
+
end if;
exception
begin
Binary_Op_Validity_Checks (N);
- -- Vax_Float is a special case
-
- if Vax_Float (Typ) then
- Expand_Vax_Arith (N);
- return;
- end if;
-
-- N / 1 = N for integer types
if Is_Integer_Type (Typ)
Analyze_And_Resolve (Left_Opnd (N), Universal_Real);
- -- Non-fixed point cases, do zero divide and overflow checks
+ -- Non-fixed point cases, do integer zero divide and overflow checks
elsif Is_Integer_Type (Typ) then
Apply_Divide_Check (N);
then
Error_Msg_CRT ("64-bit division", N);
end if;
+
+ -- Deal with Vax_Float
+
+ elsif Vax_Float (Typ) then
+ Expand_Vax_Arith (N);
+ return;
end if;
end Expand_N_Op_Divide;
begin
-- Per-object constrained selected components require special
-- attention. If the enclosing scope of the component is an
- -- Unchecked_Union, we can not reference its discriminants
+ -- Unchecked_Union, we cannot reference its discriminants
-- directly. This is why we use the two extra parameters of
-- the equality function of the enclosing Unchecked_Union.
return False;
end if;
+ -- We only need to test one component
+
declare
Comp : Node_Id := First (Component_Items (Clist));
begin
while Present (Comp) loop
-
- -- One component is sufficent
-
if Component_Is_Unconstrained_UU (Comp) then
return True;
end if;
if Ekind (Typl) = E_Private_Type then
Typl := Underlying_Type (Typl);
-
elsif Ekind (Typl) = E_Private_Subtype then
Typl := Underlying_Type (Base_Type (Typl));
+ else
+ null;
end if;
-- It may happen in error situations that the underlying type is not
Typl := Base_Type (Typl);
- -- Vax float types
-
- if Vax_Float (Typl) then
- Expand_Vax_Comparison (N);
- return;
-
-- Boolean types (requiring handling of non-standard case)
- elsif Is_Boolean_Type (Typl) then
+ if Is_Boolean_Type (Typl) then
Adjust_Condition (Left_Opnd (N));
Adjust_Condition (Right_Opnd (N));
Set_Etype (N, Standard_Boolean);
end if;
-- If we still have an equality comparison (i.e. it was not rewritten
- -- in some way), then we can test if result is needed at compile time).
+ -- in some way), then we can test if result is known at compile time).
if Nkind (N) = N_Op_Eq then
Rewrite_Comparison (N);
end if;
+
+ -- If we still have comparison for Vax_Float, process it
+
+ if Vax_Float (Typl) and then Nkind (N) in N_Op_Compare then
+ Expand_Vax_Comparison (N);
+ return;
+ end if;
end Expand_N_Op_Eq;
-----------------------
begin
Binary_Op_Validity_Checks (N);
- if Vax_Float (Typ1) then
- Expand_Vax_Comparison (N);
- return;
-
- elsif Is_Array_Type (Typ1) then
+ if Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
end if;
Rewrite_Comparison (N);
+
+ -- If we still have comparison, and Vax_Float type, process it
+
+ if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
+ Expand_Vax_Comparison (N);
+ return;
+ end if;
end Expand_N_Op_Ge;
--------------------
begin
Binary_Op_Validity_Checks (N);
- if Vax_Float (Typ1) then
- Expand_Vax_Comparison (N);
- return;
-
- elsif Is_Array_Type (Typ1) then
+ if Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
end if;
Rewrite_Comparison (N);
+
+ -- If we still have comparison, and Vax_Float type, process it
+
+ if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
+ Expand_Vax_Comparison (N);
+ return;
+ end if;
end Expand_N_Op_Gt;
--------------------
begin
Binary_Op_Validity_Checks (N);
- if Vax_Float (Typ1) then
- Expand_Vax_Comparison (N);
- return;
-
- elsif Is_Array_Type (Typ1) then
+ if Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
end if;
Rewrite_Comparison (N);
+
+ -- If we still have comparison, and Vax_Float type, process it
+
+ if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
+ Expand_Vax_Comparison (N);
+ return;
+ end if;
end Expand_N_Op_Le;
--------------------
begin
Binary_Op_Validity_Checks (N);
- if Vax_Float (Typ1) then
- Expand_Vax_Comparison (N);
- return;
-
- elsif Is_Array_Type (Typ1) then
+ if Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
end if;
Rewrite_Comparison (N);
+
+ -- If we still have comparison, and Vax_Float type, process it
+
+ if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
+ Expand_Vax_Comparison (N);
+ return;
+ end if;
end Expand_N_Op_Lt;
-----------------------
end if;
end if;
- -- Deal with VAX float case
-
- if Vax_Float (Typ) then
- Expand_Vax_Arith (N);
- return;
- end if;
-
-- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
-- Is_Power_Of_2_For_Shift is set means that we know that our left
-- operand is an integer, as required for this to work.
elsif Is_Signed_Integer_Type (Etype (N)) then
Apply_Arithmetic_Overflow_Check (N);
+
+ -- Deal with VAX float case
+
+ elsif Vax_Float (Typ) then
+ Expand_Vax_Arith (N);
+ return;
end if;
end Expand_N_Op_Multiply;
-- Expand_N_Op_Ne --
--------------------
- -- Rewrite node as the negation of an equality operation, and reanalyze.
- -- The equality to be used is defined in the same scope and has the same
- -- signature. It must be set explicitly because in an instance it may not
- -- have the same visibility as in the generic unit.
-
procedure Expand_N_Op_Ne (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Neg : Node_Id;
- Ne : constant Entity_Id := Entity (N);
+ Typ : constant Entity_Id := Etype (Left_Opnd (N));
begin
- Binary_Op_Validity_Checks (N);
+ -- Case of elementary type with standard operator
- Neg :=
- Make_Op_Not (Loc,
- Right_Opnd =>
- Make_Op_Eq (Loc,
- Left_Opnd => Left_Opnd (N),
- Right_Opnd => Right_Opnd (N)));
- Set_Paren_Count (Right_Opnd (Neg), 1);
+ if Is_Elementary_Type (Typ)
+ and then Sloc (Entity (N)) = Standard_Location
+ then
+ Binary_Op_Validity_Checks (N);
- if Scope (Ne) /= Standard_Standard then
- Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
- end if;
+ -- Boolean types (requiring handling of non-standard case)
- -- For navigation purposes, the inequality is treated as an implicit
- -- reference to the corresponding equality. Preserve the Comes_From_
- -- source flag so that the proper Xref entry is generated.
+ if Is_Boolean_Type (Typ) then
+ Adjust_Condition (Left_Opnd (N));
+ Adjust_Condition (Right_Opnd (N));
+ Set_Etype (N, Standard_Boolean);
+ Adjust_Result_Type (N, Typ);
+ end if;
- Preserve_Comes_From_Source (Neg, N);
- Preserve_Comes_From_Source (Right_Opnd (Neg), N);
- Rewrite (N, Neg);
- Analyze_And_Resolve (N, Standard_Boolean);
+ Rewrite_Comparison (N);
+
+ -- If we still have comparison for Vax_Float, process it
+
+ if Vax_Float (Typ) and then Nkind (N) in N_Op_Compare then
+ Expand_Vax_Comparison (N);
+ return;
+ end if;
+
+ -- For all cases other than elementary types, we rewrite node as the
+ -- negation of an equality operation, and reanalyze. The equality to be
+ -- used is defined in the same scope and has the same signature. This
+ -- signature must be set explicitly since in an instance it may not have
+ -- the same visibility as in the generic unit. This avoids duplicating
+ -- or factoring the complex code for record/array equality tests etc.
+
+ else
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ Neg : Node_Id;
+ Ne : constant Entity_Id := Entity (N);
+
+ begin
+ Binary_Op_Validity_Checks (N);
+
+ Neg :=
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => Left_Opnd (N),
+ Right_Opnd => Right_Opnd (N)));
+ Set_Paren_Count (Right_Opnd (Neg), 1);
+
+ if Scope (Ne) /= Standard_Standard then
+ Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
+ end if;
+
+ -- For navigation purposes, the inequality is treated as an
+ -- implicit reference to the corresponding equality. Preserve the
+ -- Comes_From_ source flag so that the proper Xref entry is
+ -- generated.
+
+ Preserve_Comes_From_Source (Neg, N);
+ Preserve_Comes_From_Source (Right_Opnd (Neg), N);
+ Rewrite (N, Neg);
+ Analyze_And_Resolve (N, Standard_Boolean);
+ end;
+ end if;
end Expand_N_Op_Ne;
---------------------
-- then we do not trust it to be in range (might be infinite)
declare
- S_Lo : constant Node_Id := Type_Low_Bound (Xtyp);
- S_Hi : constant Node_Id := Type_High_Bound (Xtyp);
+ S_Lo : constant Node_Id := Type_Low_Bound (Xtyp);
+ S_Hi : constant Node_Id := Type_High_Bound (Xtyp);
begin
if (not Is_Floating_Point_Type (Xtyp)
(Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
Set_Etype (Conv, Btyp);
- -- Enable overflow except in the case of integer to float
- -- conversions, where it is never required, since we can
- -- never have overflow in this case.
+ -- Enable overflow except for case of integer to float conversions,
+ -- where it is never required, since we can never have overflow in
+ -- this case.
if not Is_Integer_Type (Etype (Operand)) then
Enable_Overflow_Check (Conv);
return;
end if;
- -- Deal with Vax floating-point cases
-
- if Vax_Float (Operand_Type) or else Vax_Float (Target_Type) then
- Expand_Vax_Conversion (N);
- return;
- end if;
-
-- Nothing to do if this is the second argument of read. This
-- is a "backwards" conversion that will be handled by the
-- specialized code in attribute processing.
-- this type with proper overflow checking, and so gigi is doing an
-- approximation of what is required by doing floating-point compares
-- with the end-point. But that can lose precision in some cases, and
- -- give a wrong result. Converting the operand to Long_Long_Float is
+ -- give a wrong result. Converting the operand to Universal_Real is
-- helpful, but still does not catch all cases with 64-bit integers
-- on targets with only 64-bit floats ???
Rewrite (Operand,
Make_Type_Conversion (Loc,
Subtype_Mark =>
- New_Occurrence_Of (Standard_Long_Long_Float, Loc),
+ New_Occurrence_Of (Universal_Real, Loc),
Expression =>
Relocate_Node (Operand)));
- Set_Etype (Operand, Standard_Long_Long_Float);
+ Set_Etype (Operand, Universal_Real);
Enable_Range_Check (Operand);
Set_Do_Range_Check (Expression (Operand), False);
end if;
elsif Is_Floating_Point_Type (Target_Type) then
Real_Range_Check;
-
- -- The remaining cases require no front end processing
-
- else
- null;
end if;
-- At this stage, either the conversion node has been transformed
end if;
end;
end if;
+
+ -- Final step, if the result is a type conversion involving Vax_Float
+ -- types, then it is subject for further special processing.
+
+ if Nkind (N) = N_Type_Conversion
+ and then (Vax_Float (Operand_Type) or else Vax_Float (Target_Type))
+ then
+ Expand_Vax_Conversion (N);
+ return;
+ end if;
end Expand_N_Type_Conversion;
-----------------------------------
Statements => New_List (If_Stat)));
return Func_Body;
-
end Make_Array_Comparison_Op;
---------------------------
True_Result := Res in Compare_GE;
False_Result := Res = LT;
+ if Res = LE
+ and then Constant_Condition_Warnings
+ and then Comes_From_Source (Original_Node (N))
+ and then Nkind (Original_Node (N)) = N_Op_Ge
+ and then not In_Instance
+ and then not Warnings_Off (Etype (Left_Opnd (N)))
+ and then Is_Integer_Type (Etype (Left_Opnd (N)))
+ then
+ Error_Msg_N
+ ("can never be greater than, could replace by ""'=""?", N);
+ end if;
+
when N_Op_Gt =>
True_Result := Res = GT;
False_Result := Res in Compare_LE;
True_Result := Res in Compare_LE;
False_Result := Res = GT;
+ if Res = GE
+ and then Constant_Condition_Warnings
+ and then Comes_From_Source (Original_Node (N))
+ and then Nkind (Original_Node (N)) = N_Op_Le
+ and then not In_Instance
+ and then not Warnings_Off (Etype (Left_Opnd (N)))
+ and then Is_Integer_Type (Etype (Left_Opnd (N)))
+ then
+ Error_Msg_N
+ ("can never be less than, could replace by ""'=""?", N);
+ end if;
+
when N_Op_Ne =>
- True_Result := Res = NE;
- False_Result := Res = LT or else Res = GT or else Res = EQ;
+ True_Result := Res = NE or else Res = GT or else Res = LT;
+ False_Result := Res = EQ;
end case;
if True_Result then
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2005, 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- --
end loop;
end if;
- Success := Total_Errors_Detected <= 0;
+ Success := Total_Errors_Detected = 0;
end Process;
-------------------------------
-- B o d y --
-- (Version for Alpha/Dec Unix) --
-- --
--- Copyright (C) 1999-2005 Ada Core Technologies, Inc. --
+-- Copyright (C) 1999-2005, AdaCore --
-- --
-- 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- --
Prf : constant System.Address := exc_lookup_function (Get_Code_Loc (M));
begin
- if (Prf = System.Null_Address) then
+ if Prf = System.Null_Address then
c_set_code_loc (M, 0);
else
exc_virtual_unwind (Prf, M);
begin
-- Check that caller is abort-deferred
- if Self_ID.Deferral_Level <= 0 then
+ if Self_ID.Deferral_Level = 0 then
return False;
end if;
-- Check that caller is abort-deferred
- if Self_ID.Deferral_Level <= 0 then
+ if Self_ID.Deferral_Level = 0 then
return False;
end if;
begin
-- Check that caller is abort-deferred
- if Self_ID.Deferral_Level <= 0 then
+ if Self_ID.Deferral_Level = 0 then
return False;
end if;
-- Check that caller is abort-deferred
- if Self_ID.Deferral_Level <= 0 then
+ if Self_ID.Deferral_Level = 0 then
return False;
end if;
begin
-- Check that caller is abort-deferred
- if Self_ID.Deferral_Level <= 0 then
+ if Self_ID.Deferral_Level = 0 then
return False;
end if;
-- Check that caller is abort-deferred
- if Self_ID.Deferral_Level <= 0 then
+ if Self_ID.Deferral_Level = 0 then
return False;
end if;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sem_VFpt; use Sem_VFpt;
+with Sem_Warn; use Sem_Warn;
with Stand; use Stand;
with Sinfo; use Sinfo;
with Sinfo.CN; use Sinfo.CN;
Pragma_Exit : exception;
-- This exception is used to exit pragma processing completely. It
- -- is used when an error is detected, and in other situations where
- -- it is known that no further processing is required.
+ -- is used when an error is detected, and no further processing is
+ -- required. It is also used if an earlier error has left the tree
+ -- in a state where the pragma should not be processed.
Arg_Count : Nat;
-- Number of pragma argument associations
Analyze (Expression (Arg1));
- if Unit_Kind = N_Generic_Subprogram_Declaration
+ if Unit_Kind = N_Generic_Subprogram_Declaration
or else Unit_Kind = N_Subprogram_Declaration
then
Unit_Name := Defining_Entity (Unit_Node);
- elsif Unit_Kind = N_Function_Instantiation
- or else Unit_Kind = N_Package_Instantiation
- or else Unit_Kind = N_Procedure_Instantiation
- then
+ elsif Unit_Kind in N_Generic_Instantiation then
Unit_Name := Defining_Entity (Unit_Node);
else
and then Ekind (E) /= E_Variable
and then not
(Is_Access_Type (E)
- and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
+ and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
then
Error_Pragma_Arg
("second argument of pragma% must be subprogram (type)",
-- suppress check for any check id value.
if C = All_Checks then
+
+ -- For All_Checks, we set all specific checks with the
+ -- exception of Elaboration_Check, which is handled specially
+ -- because of not wanting All_Checks to have the effect of
+ -- deactivating static elaboration order processing.
+
for J in Scope_Suppress'Range loop
- Scope_Suppress (J) := Suppress_Case;
+ if J /= Elaboration_Check then
+ Scope_Suppress (J) := Suppress_Case;
+ end if;
end loop;
+
+ -- If not All_Checks, just set appropriate entry. Note that we
+ -- will set Elaboration_Check if this is explicitly specified.
+
else
Scope_Suppress (C) := Suppress_Case;
end if;
if Warn_On_Unrecognized_Pragma then
Error_Pragma ("unrecognized pragma%!?");
else
- raise Pragma_Exit;
+ return;
end if;
else
Prag_Id := Get_Pragma_Id (Chars (N));
Error_Pragma ("pragma% must refer to a spec, not a body");
else
Set_Body_Required (Cunit_Node, True);
- Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
+ Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
-- If we are in dynamic elaboration mode, then we suppress
-- elaboration warnings for the unit, since it is definitely
Present (Source_Location)
then
Error_Pragma
- ("parameter profile and source location can not " &
+ ("parameter profile and source location cannot " &
"be used together in pragma%");
end if;
S : String_Id;
Active : Boolean := True;
+ procedure Check_Obsolete_Subprogram;
+ -- Checks if Subp is a subprogram declaration node, and if so
+ -- replaces Subp by the defining entity of the subprogram. If not,
+ -- issues an error message
+
+ ------------------------------
+ -- Check_Obsolete_Subprogram--
+ ------------------------------
+
+ procedure Check_Obsolete_Subprogram is
+ begin
+ if Nkind (Subp) /= N_Subprogram_Declaration then
+ Error_Pragma
+ ("pragma% misplaced, must immediately " &
+ "follow subprogram/package declaration");
+ else
+ Subp := Defining_Entity (Subp);
+ end if;
+ end Check_Obsolete_Subprogram;
+
+ -- Start of processing for pragma Obsolescent
+
begin
GNAT_Pragma;
Check_At_Most_N_Arguments (2);
if Present (Prev (N)) then
Subp := Prev (N);
+ Check_Obsolete_Subprogram;
-- Second possibility, stand alone subprogram declaration with the
-- pragma immediately following the declaration.
and then Nkind (Parent (N)) = N_Compilation_Unit_Aux
then
Subp := Unit (Parent (Parent (N)));
+ Check_Obsolete_Subprogram;
- -- Any other possibility is a misplacement
+ -- Only other possibility is library unit placement for package
else
- Subp := Empty;
- end if;
-
- -- Check correct placement
+ Subp := Find_Lib_Unit_Name;
- if Nkind (Subp) /= N_Subprogram_Declaration then
- Error_Pragma
- ("pragma% misplaced, must immediately " &
- "follow subprogram spec");
+ if Ekind (Subp) /= E_Package
+ and then Ekind (Subp) /= E_Generic_Package
+ then
+ Check_Obsolete_Subprogram;
+ end if;
end if;
-- If OK placement, acquire arguments
- Subp := Defining_Entity (Subp);
-
if Arg_Count >= 1 then
-- Deal with static string argument
("pragma% requires separate spec and must come before body");
elsif Rep_Item_Too_Early (E, N)
- or else
- Rep_Item_Too_Late (E, N)
+ or else Rep_Item_Too_Late (E, N)
then
raise Pragma_Exit;
--------------
-- pragma Warnings (On | Off, [LOCAL_NAME])
+ -- pragma Warnings (static_string_EXPRESSION);
when Pragma_Warnings => Warnings : begin
GNAT_Pragma;
Check_At_Least_N_Arguments (1);
- Check_At_Most_N_Arguments (2);
Check_No_Identifiers;
- -- One argument case was processed by parser in Par.Prag
+ -- One argument case
- if Arg_Count /= 1 then
+ if Arg_Count = 1 then
+ declare
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
+
+ begin
+ -- On/Off one argument case was processed by parser
+
+ if Nkind (Argx) = N_Identifier
+ and then
+ (Chars (Argx) = Name_On
+ or else
+ Chars (Argx) = Name_Off)
+ then
+ null;
+
+ else
+ Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+
+ declare
+ Lit : constant Node_Id := Expr_Value_S (Argx);
+ Str : constant String_Id := Strval (Lit);
+ C : Char_Code;
+
+ begin
+ for J in 1 .. String_Length (Str) loop
+ C := Get_String_Char (Str, J);
+
+ if In_Character_Range (C)
+ and then Set_Warning_Switch (Get_Character (C))
+ then
+ null;
+ else
+ Error_Pragma_Arg
+ ("invalid warning switch character", Arg1);
+ end if;
+ end loop;
+ end;
+ end if;
+ end;
+
+ -- Two argument case
+
+ elsif Arg_Count /= 1 then
Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
Check_Arg_Count (2);
-- is a conversion. Retrieve the real entity name.
if (In_Instance_Body
- or else In_Inlined_Body)
+ or else In_Inlined_Body)
and then Nkind (E_Id) = N_Unchecked_Type_Conversion
then
E_Id := Expression (E_Id);
return;
else
loop
- Set_Warnings_Off (E,
- (Chars (Expression (Arg1)) = Name_Off));
+ Set_Warnings_Off
+ (E, (Chars (Expression (Arg1)) = Name_Off));
if Is_Enumeration_Type (E) then
declare
end loop;
end if;
end;
+
+ -- More than two arguments
+ else
+ Check_At_Most_N_Arguments (2);
end if;
end Warnings;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005, 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- --
-- (logically this processing belongs in chapter 4)
with Types; use Types;
+
package Sem_Prag is
procedure Analyze_Pragma (N : Node_Id);
-- Analyze procedure for pragma reference node N
function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean;
- -- N is a pragma appearing in a configuration pragma file. Most
- -- such pragmas are analyzed when the file is read, before parsing
- -- and analyzing the main unit. However, the analysis of certain
- -- pragmas results in adding information to the compiled main unit,
- -- and this cannot be done till the main unit is processed. Such
- -- pragmas return True from this function and in Frontend pragmas
- -- where Delay_Config_Pragma_Analyze is True have their analysis
- -- delayed until after the main program is parsed and analyzed.
+ -- N is a pragma appearing in a configuration pragma file. Most such
+ -- pragmas are analyzed when the file is read, before parsing and analyzing
+ -- the main unit. However, the analysis of certain pragmas results in
+ -- adding information to the compiled main unit, and this cannot be done
+ -- till the main unit is processed. Such pragmas return True from this
+ -- function and in Frontend pragmas where Delay_Config_Pragma_Analyze is
+ -- True have their analysis delayed until after the main program is parsed
+ -- and analyzed.
function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean;
-- The node N is a node for an entity and the issue is whether the
- -- occurrence is a reference for the purposes of giving warnings
- -- about unreferenced variables. This function returns True if the
- -- reference is not a reference from this point of view (e.g. the
- -- occurrence in a pragma Pack) and False if it is a real reference
- -- (e.g. the occcurrence in a pragma Export);
+ -- occurrence is a reference for the purposes of giving warnings about
+ -- unreferenced variables. This function returns True if the reference is
+ -- not a reference from this point of view (e.g. the occurrence in a pragma
+ -- Pack) and False if it is a real reference (e.g. the occcurrence in a
+ -- pragma Export);
function Is_Pragma_String_Literal (Par : Node_Id) return Boolean;
- -- Given an N_Pragma_Argument_Association node, Par, which has the form
- -- of an operator symbol, determines whether or not it should be treated
- -- as an string literal. This is called by Sem_Ch6.Analyze_Operator_Symbol.
- -- If True is returned, the argument is converted to a string literal. If
+ -- Given an N_Pragma_Argument_Association node, Par, which has the form of
+ -- an operator symbol, determines whether or not it should be treated as an
+ -- string literal. This is called by Sem_Ch6.Analyze_Operator_Symbol. If
+ -- True is returned, the argument is converted to a string literal. If
-- False is returned, then the argument is treated as an entity reference
-- to the operator.
function Is_Config_Static_String (Arg : Node_Id) return Boolean;
- -- This is called for a configuration pragma that requires either a
- -- string literal or a concatenation of string literals. We cannot
- -- use normal static string processing because it is too early in
- -- the case of the pragma appearing in a configuration pragmas file.
- -- If Arg is of an appropriate form, then this call obtains the string
- -- (doing any necessary concatenations) and places it in Name_Buffer,
- -- setting Name_Len to its length, and then returns True. If it is
- -- not of the correct form, then an appropriate error message is
- -- posted, and False is returned.
+ -- This is called for a configuration pragma that requires either string
+ -- literal or a concatenation of string literals. We cannot use normal
+ -- static string processing because it is too early in the case of the
+ -- pragma appearing in a configuration pragmas file. If Arg is of an
+ -- appropriate form, then this call obtains the string (doing any necessary
+ -- concatenations) and places it in Name_Buffer, setting Name_Len to its
+ -- length, and then returns True. If it is not of the correct form, then an
+ -- appropriate error message is posted, and False is returned.
procedure Process_Compilation_Unit_Pragmas (N : Node_Id);
- -- Called at the start of processing compilation unit N to deal with
- -- any special issues regarding pragmas. In particular, we have to
- -- deal with Suppress_All at this stage, since it appears after the
- -- unit instead of before.
+ -- Called at the start of processing compilation unit N to deal with any
+ -- special issues regarding pragmas. In particular, we have to deal with
+ -- Suppress_All at this stage, since it appears after the unit instead of
+ -- before.
procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id);
- -- This routine is used to set an encoded interface name. The node
- -- S is an N_String_Literal node for the external name to be set, and
- -- E is an entity whose Interface_Name field is to be set. In the
- -- normal case where S contains a name that is a valid C identifier,
- -- then S is simply set as the value of the Interface_Name. Otherwise
- -- it is encoded. See the body for details of the encoding. This
- -- encoding is only done on VMS systems, since it seems pretty silly,
- -- but is needed to pass some dubious tests in the test suite.
+ -- This routine is used to set an encoded interface name. The node S is an
+ -- N_String_Literal node for the external name to be set, and E is an
+ -- entity whose Interface_Name field is to be set. In the normal case where
+ -- S contains a name that is a valid C identifier, then S is simply set as
+ -- the value of the Interface_Name. Otherwise it is encoded. See the body
+ -- for details of the encoding. This encoding is only done on VMS systems,
+ -- since it seems pretty silly, but is needed to pass some dubious tests in
+ -- the test suite.
end Sem_Prag;
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2005, 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- --
with Opt; use Opt;
with Prepcomp; use Prepcomp;
with Validsw; use Validsw;
+with Sem_Warn; use Sem_Warn;
with Stylesw; use Stylesw;
with System.WCh_Con; use System.WCh_Con;
-- Skip past the initial character (must be the switch character)
if Ptr = Max then
- raise Bad_Switch;
+ Bad_Switch (C);
else
Ptr := Ptr + 1;
end if;
Ptr := Ptr + 1;
if Ptr > Max then
- raise Bad_Switch;
+ Bad_Switch (C);
end if;
-- Find out whether this is a -I- or regular -Ixxx switch
end if;
end if;
else
- raise Bad_Switch;
+ Bad_Switch (C);
end if;
when True =>
Dot := True;
else
- raise Bad_Switch;
+ Bad_Switch (C);
end if;
end loop;
-- so we must always have a character after the e.
if Ptr > Max then
- raise Bad_Switch;
+ Bad_Switch (C);
end if;
case Switch_Chars (Ptr) is
end if;
if Ptr > Max then
- raise Bad_Switch;
+ Bad_Switch (C);
end if;
declare
Ptr := Ptr + 1;
if Ptr > Max then
- raise Bad_Switch;
+ Bad_Switch (C);
end if;
Add_Symbol_Definition (Switch_Chars (Ptr .. Max));
when 'I' =>
Ptr := Ptr + 1;
- Scan_Pos (Switch_Chars, Max, Ptr, Multiple_Unit_Index);
+ Scan_Pos
+ (Switch_Chars, Max, Ptr, Multiple_Unit_Index, C);
-- -gnatem (mapping file)
end if;
if Ptr > Max then
- raise Bad_Switch;
+ Bad_Switch (C);
end if;
Mapping_File_Name :=
end if;
if Ptr > Max then
- raise Bad_Switch;
+ Bad_Switch (C);
end if;
Preprocessing_Data_File :=
-- All other -gnate? switches are unassigned
when others =>
- raise Bad_Switch;
+ Bad_Switch (C);
end case;
-- -gnatE (dynamic elaboration checks)
Warn_On_Unchecked_Conversion := True;
Warn_On_Unrecognized_Pragma := True;
- Set_Style_Check_Options ("3abcdefhiklmnprstu");
+ Set_Style_Check_Options ("3abcdefhiklmnprstux");
-- Processing for G switch
when 'i' =>
if Ptr = Max then
- raise Bad_Switch;
+ Bad_Switch (C);
end if;
Ptr := Ptr + 1;
Ptr := Ptr + 1;
else
- raise Bad_Switch;
+ Bad_Switch (C);
end if;
-- Processing for k switch
when 'k' =>
Ptr := Ptr + 1;
- Scan_Pos (Switch_Chars, Max, Ptr, Maximum_File_Name_Length);
+ Scan_Pos
+ (Switch_Chars, Max, Ptr, Maximum_File_Name_Length, C);
-- Processing for l switch
when 'm' =>
Ptr := Ptr + 1;
- Scan_Pos (Switch_Chars, Max, Ptr, Maximum_Errors);
+
+ -- There may be an equal sign between -gnatm and the value
+
+ if Ptr <= Max and then Switch_Chars (Ptr) = '=' then
+ Ptr := Ptr + 1;
+ end if;
+
+ Scan_Pos (Switch_Chars, Max, Ptr, Maximum_Errors, C);
-- Processing for n switch
when 'p' =>
Ptr := Ptr + 1;
- Suppress_Options := (others => True);
+
+ -- Set all specific options as well as All_Checks in the
+ -- Suppress_Options array, excluding Elaboration_Check, since
+ -- this is treated specially because we do not want -gnatp to
+ -- disable static elaboration processing.
+
+ for J in Suppress_Options'Range loop
+ if J /= Elaboration_Check then
+ Suppress_Options (J) := True;
+ end if;
+ end loop;
+
Validity_Checks_On := False;
Opt.Suppress_Checks := True;
Opt.Enable_Overflow_Checks := False;
List_Representation_Info_Mechanisms := True;
else
- raise Bad_Switch;
+ Bad_Switch (C);
end if;
Ptr := Ptr + 1;
when 'T' =>
Ptr := Ptr + 1;
- Scan_Pos (Switch_Chars, Max, Ptr, Table_Factor);
+ Scan_Pos (Switch_Chars, Max, Ptr, Table_Factor, C);
-- Processing for u switch
Ptr := Ptr + 1;
if Ptr > Max then
- raise Bad_Switch;
+ Bad_Switch (C);
else
declare
(Switch_Chars (Ptr .. Max), OK, Ptr);
if not OK then
- raise Bad_Switch;
+ Bad_Switch (C);
end if;
for Index in First_Char + 1 .. Max loop
Ptr := Ptr + 1;
if Ptr > Max then
- raise Bad_Switch;
+ Bad_Switch (C);
end if;
while Ptr <= Max loop
C := Switch_Chars (Ptr);
- case C is
- when 'a' =>
- Check_Unreferenced := True;
- Check_Unreferenced_Formals := True;
- Check_Withs := True;
- Constant_Condition_Warnings := True;
- Implementation_Unit_Warnings := True;
- Ineffective_Inline_Warnings := True;
- Warn_On_Ada_2005_Compatibility := True;
- Warn_On_Bad_Fixed_Value := True;
- Warn_On_Constant := True;
- Warn_On_Export_Import := True;
- Warn_On_Modified_Unread := True;
- Warn_On_No_Value_Assigned := True;
- Warn_On_Obsolescent_Feature := True;
- Warn_On_Redundant_Constructs := True;
- Warn_On_Unchecked_Conversion := True;
- Warn_On_Unrecognized_Pragma := True;
-
- when 'A' =>
- Check_Unreferenced := False;
- Check_Unreferenced_Formals := False;
- Check_Withs := False;
- Constant_Condition_Warnings := False;
- Elab_Warnings := False;
- Implementation_Unit_Warnings := False;
- Ineffective_Inline_Warnings := False;
- Warn_On_Ada_2005_Compatibility := False;
- Warn_On_Bad_Fixed_Value := False;
- Warn_On_Constant := False;
- Warn_On_Dereference := False;
- Warn_On_Export_Import := False;
- Warn_On_Hiding := False;
- Warn_On_Modified_Unread := False;
- Warn_On_No_Value_Assigned := False;
- Warn_On_Obsolescent_Feature := False;
- Warn_On_Redundant_Constructs := False;
- Warn_On_Unchecked_Conversion := False;
- Warn_On_Unrecognized_Pragma := False;
-
- when 'b' =>
- Warn_On_Bad_Fixed_Value := True;
-
- when 'B' =>
- Warn_On_Bad_Fixed_Value := False;
-
- when 'c' =>
- Constant_Condition_Warnings := True;
-
- when 'C' =>
- Constant_Condition_Warnings := False;
-
- when 'd' =>
- Warn_On_Dereference := True;
-
- when 'D' =>
- Warn_On_Dereference := False;
-
- when 'e' =>
- Warning_Mode := Treat_As_Error;
-
- when 'f' =>
- Check_Unreferenced_Formals := True;
-
- when 'F' =>
- Check_Unreferenced_Formals := False;
-
- when 'g' =>
- Warn_On_Unrecognized_Pragma := True;
-
- when 'G' =>
- Warn_On_Unrecognized_Pragma := False;
-
- when 'h' =>
- Warn_On_Hiding := True;
-
- when 'H' =>
- Warn_On_Hiding := False;
-
- when 'i' =>
- Implementation_Unit_Warnings := True;
-
- when 'I' =>
- Implementation_Unit_Warnings := False;
-
- when 'j' =>
- Warn_On_Obsolescent_Feature := True;
-
- when 'J' =>
- Warn_On_Obsolescent_Feature := False;
-
- when 'k' =>
- Warn_On_Constant := True;
-
- when 'K' =>
- Warn_On_Constant := False;
-
- when 'l' =>
- Elab_Warnings := True;
-
- when 'L' =>
- Elab_Warnings := False;
-
- when 'm' =>
- Warn_On_Modified_Unread := True;
-
- when 'M' =>
- Warn_On_Modified_Unread := False;
-
- when 'n' =>
- Warning_Mode := Normal;
-
- when 'o' =>
- Address_Clause_Overlay_Warnings := True;
-
- when 'O' =>
- Address_Clause_Overlay_Warnings := False;
-
- when 'p' =>
- Ineffective_Inline_Warnings := True;
-
- when 'P' =>
- Ineffective_Inline_Warnings := False;
-
- when 'r' =>
- Warn_On_Redundant_Constructs := True;
-
- when 'R' =>
- Warn_On_Redundant_Constructs := False;
-
- when 's' =>
- Warning_Mode := Suppress;
-
- when 'u' =>
- Check_Unreferenced := True;
- Check_Withs := True;
- Check_Unreferenced_Formals := True;
-
- when 'U' =>
- Check_Unreferenced := False;
- Check_Withs := False;
- Check_Unreferenced_Formals := False;
-
- when 'v' =>
- Warn_On_No_Value_Assigned := True;
-
- when 'V' =>
- Warn_On_No_Value_Assigned := False;
-
- when 'x' =>
- Warn_On_Export_Import := True;
-
- when 'X' =>
- Warn_On_Export_Import := False;
-
- when 'y' =>
- Warn_On_Ada_2005_Compatibility := True;
-
- when 'Y' =>
- Warn_On_Ada_2005_Compatibility := False;
-
- when 'z' =>
- Warn_On_Unchecked_Conversion := True;
-
- when 'Z' =>
- Warn_On_Unchecked_Conversion := False;
-
- -- Allow and ignore 'w' so that the old
- -- format (e.g. -gnatwuwl) will work.
-
- when 'w' =>
- null;
-
- when others =>
- raise Bad_Switch;
- end case;
+ if Set_Warning_Switch (C) then
+ null;
+ else
+ Bad_Switch (C);
+ end if;
if C /= 'w' then
Storing (First_Stored + 1) := C;
Ptr := Ptr + 1;
if Ptr > Max then
- raise Bad_Switch;
+ Bad_Switch (C);
end if;
for J in WC_Encoding_Method loop
exit;
elsif J = WC_Encoding_Method'Last then
- raise Bad_Switch;
+ Bad_Switch (C);
end if;
end loop;
(Switch_Chars (Ptr .. Max), OK, Ptr);
if not OK then
- raise Bad_Switch;
+ Bad_Switch (C);
end if;
Ptr := First_Char + 1;
Distribution_Stub_Mode := Generate_Caller_Stub_Body;
when others =>
- raise Bad_Switch;
+ Bad_Switch (C);
end case;
Ptr := Ptr + 1;
when '8' =>
if Ptr = Max then
- raise Bad_Switch;
+ Bad_Switch (C);
end if;
Ptr := Ptr + 1;
if Switch_Chars (Ptr) /= '3' then
- raise Bad_Switch;
+ Bad_Switch (C);
else
Ptr := Ptr + 1;
Ada_Version := Ada_83;
when '9' =>
if Ptr = Max then
- raise Bad_Switch;
+ Bad_Switch (C);
end if;
Ptr := Ptr + 1;
if Switch_Chars (Ptr) /= '5' then
- raise Bad_Switch;
+ Bad_Switch (C);
else
Ptr := Ptr + 1;
Ada_Version := Ada_95;
when '0' =>
if Ptr = Max then
- raise Bad_Switch;
+ Bad_Switch (C);
end if;
Ptr := Ptr + 1;
if Switch_Chars (Ptr) /= '5' then
- raise Bad_Switch;
+ Bad_Switch (C);
else
Ptr := Ptr + 1;
Ada_Version := Ada_05;
-- Anything else is an error (illegal switch character)
when others =>
- raise Bad_Switch;
+ Bad_Switch (C);
end case;
end case;
First_Switch := False;
end loop;
-
- exception
- when Bad_Switch =>
- Osint.Fail ("invalid switch: ", (1 => C));
-
- when Bad_Switch_Value =>
- Osint.Fail ("numeric value out of range for switch: ", (1 => C));
-
- when Missing_Switch_Value =>
- Osint.Fail ("missing numeric value for switch: ", (1 => C));
-
end Scan_Front_End_Switches;
end Switch.C;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005, 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- --
-- is in practice infinite and there is no need to check the range.
Ureal_Low_Bound : constant := 500_000_000;
- -- Low bound for Ureal values.
+ -- Low bound for Ureal values
Ureal_High_Bound : constant := 599_999_999;
-- Maximum number of Ureal values stored is 100_000_000 which is in
-- practice infinite so that no check is required.
Uint_Low_Bound : constant := 600_000_000;
- -- Low bound for Uint values.
+ -- Low bound for Uint values
Uint_Table_Start : constant := 2_000_000_000;
-- Location where table entries for universal integers start (see
-- are not valid.
First_Elist_Id : constant Elist_Id := No_Elist + 1;
- -- Subscript of first allocated Elist header.
+ -- Subscript of first allocated Elist header
-- Element Id values are used to identify individual elements of an
-- element list (see package Elists for further details).
Tag_Check,
All_Checks);
- -- The following record contains an entry for each recognized check name
+ -- The following array contains an entry for each recognized check name
-- for pragma Suppress. It is used to represent current settings of scope
-- based suppress actions from pragma Suppress or command line settings.
- type Suppress_Array is
- array (Check_Id range Access_Check .. Tag_Check) of Boolean;
+ -- Note: when Suppress_Array (All_Checks) is True, then generally all other
+ -- specific check entries are set True, except for the Elaboration_Check
+ -- entry which is set only if an explicit Suppress for this check is given.
+ -- The reason for this non-uniformity is that we do not want All_Checks to
+ -- suppress elaboration checking when using the static elaboration model.
+ -- We recognize only an explicit suppress of Elaboration_Check as a signal
+ -- that the static elaboration checking should skip a compile time check.
+
+ type Suppress_Array is array (Check_Id) of Boolean;
pragma Pack (Suppress_Array);
-- To add a new check type to GNAT, the following steps are required:
projects / thirdparty / gcc.git / commitdiff
