Skip to content

R
riscv-gcc-1
Commit f02b8bb8 by Robert Dewar Committed by Arnaud Charlet
Options

re PR ada/18434 (Ada: cannot build gnattools on Tru64 UNIX V5.1B) 

2005-11-14  Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	PR ada/18434

	* types.ads: Include All_Checks in Suppress_Array

	* checks.adb (Check_Needed): Remove kludge for a/=b rewritten as
	not(a=b), since we no longer do this rewriting, and hence it is not
	needed.
	(Elaboration_Checks_Suppressed): Add special casing to
	deal with different cases of static and dynamic elaboration checks (all
	checks does not count in the first case, but does in the second).
	(Expr_Known_Valid): Do not assume that the result of any arbitrary
	function call is valid, since this is not the case.
	(Ensure_Valid): Do not apply validity check to a real literal
	in a universal or fixed context

	* exp_ch4.adb (Expand_N_Op_Ne): Don't expand a/=b to not(a=b) for
	elementary types using the operator in standard. It is cleaner not to
	modify the programmers intent, especially in the case of floating-point.
	(Rewrite_Comparison): Fix handling of /= (this was always wrong, but
	it did not matter because we always rewrote a/=b to not(a=b).
	(Expand_Allocator_Expression): For an allocator expression whose nominal
	subtype is an unconstrained packed type, convert the expression to its
	actual constrained subtype.
	Implement warning for <= or >= where < or > not possible
	Fix to Vax_Float tests (too early in many routines, causing premature
	Vax_Float expansions.

	* sem_prag.adb (Analyze_Pragma, case Obsolescent): Allow this pragma
	to be used with packages and generic packages as well as with
	subprograms.
	(Suppress): Set All_Checks, but not Elaboration_Check, for case
	of pragma Suppress (All_Checks)
	(Analyze_Pragma, case Warnings): Implement first argument allowed to be
	a string literal for precise control over warnings.
	Avoid raise of pragma in case of unrecognized pragma and just return
	instead.

	* sem_prag.ads: Minor reformatting

	* switch-c.adb (Scan_Front_End_Switches): Replace "raise Bad_Switch;"
	with call to new procedure Bad_Switch. Call Scan_Pos with new parameter
	Switch. Do not handle any exception.
	Include -gnatwx as part of -gnatg (warn on redundant parens)
	Allow optional = after -gnatm
	(Scan_Front_End_Switches): The -gnatp switch sets All_Checks, but no
	longer sets Elaboration_Checks.
	Code to set warning mode moved to Sem_Warn
	so that it can be shared by pragma processing.

	* s-mastop-tru64.adb (Pop_Frame): Remove redundant parentheses in if
	statement.

	* s-taprop-solaris.adb: 
	Change some <= to =, to avoid new warning

	* a-exexda.adb, prj-proc.adb: 
	Fix obvious typo (Num_Tracebacks compared <= 0 instead of < 0)
	Fix obvious typo (Total_Errors_Detected <= 0 should be = 0)

From-SVN: r106950
parent 3e1fd98f
Showing with 441 additions and 405 deletions
gcc/ada/a-exexda.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -386,7 +386,7 @@ package body Exception_Data is ...@@ -386,7 +386,7 @@ package body Exception_Data is
Ptr : in out Natural) Ptr : in out Natural)
is is
begin begin
if X.Num_Tracebacks <= 0 then if X.Num_Tracebacks = 0 then
return; return;
end if; end if;
......
gcc/ada/checks.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -2481,13 +2481,11 @@ package body Checks is ...@@ -2481,13 +2481,11 @@ package body Checks is
exit when N = Right_Opnd (P) exit when N = Right_Opnd (P)
and then Nkind (Left_Opnd (P)) = N_Op_Eq; and then Nkind (Left_Opnd (P)) = N_Op_Eq;
-- And/And then case, left operand must be inequality test. Note that -- And/And then case, left operand must be inequality test
-- at this stage, the expander will have changed a/=b to not (a=b).
elsif K = N_Op_And or else K = N_And_Then then elsif K = N_Op_And or else K = N_And_Then then
exit when N = Right_Opnd (P) exit when N = Right_Opnd (P)
and then Nkind (Left_Opnd (P)) = N_Op_Not and then Nkind (Left_Opnd (P)) = N_Op_Ne;
and then Nkind (Right_Opnd (Left_Opnd (P))) = N_Op_Eq;
end if; end if;
N := P; N := P;
...@@ -3259,15 +3257,32 @@ package body Checks is ...@@ -3259,15 +3257,32 @@ package body Checks is
function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is
begin 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 Present (E) then
if Kill_Elaboration_Checks (E) then if Kill_Elaboration_Checks (E) then
return True; return True;
elsif Checks_May_Be_Suppressed (E) then 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;
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; end Elaboration_Checks_Suppressed;
--------------------------- ---------------------------
...@@ -3690,6 +3705,15 @@ package body Checks is ...@@ -3690,6 +3705,15 @@ package body Checks is
then then
return; 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 -- 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 -- type, then the value is not going to be accessed, therefore it is
-- inappropriate to do any validity check at the call site. -- inappropriate to do any validity check at the call site.
...@@ -3845,11 +3869,10 @@ package body Checks is ...@@ -3845,11 +3869,10 @@ package body Checks is
then then
return Expr_Known_Valid (Expression (Expr)); return Expr_Known_Valid (Expression (Expr));
-- The result of any function call or operator is always considered -- The result of any operator is always considered valid, since we
-- valid, since we assume the necessary checks are done by the call. -- assume the necessary checks are done by the operator. For operators
-- For operators on floating-point operations, we must also check -- on floating-point operations, we must also check when the operation
-- when the operation is the right-hand side of an assignment, or -- is the right-hand side of an assignment, or is an actual in a call.
-- is an actual in a call.
elsif elsif
Nkind (Expr) in N_Binary_Op or else Nkind (Expr) in N_Unary_Op Nkind (Expr) in N_Binary_Op or else Nkind (Expr) in N_Unary_Op
...@@ -3866,9 +3889,6 @@ package body Checks is ...@@ -3866,9 +3889,6 @@ package body Checks is
return True; return True;
end if; end if;
elsif Nkind (Expr) = N_Function_Call then
return True;
-- For all other cases, we do not know the expression is valid -- For all other cases, we do not know the expression is valid
else else
......
gcc/ada/exp_ch4.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -38,6 +38,7 @@ with Exp_Pakd; use Exp_Pakd; ...@@ -38,6 +38,7 @@ with Exp_Pakd; use Exp_Pakd;
with Exp_Tss; use Exp_Tss; with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util; with Exp_Util; use Exp_Util;
with Exp_VFpt; use Exp_VFpt; with Exp_VFpt; use Exp_VFpt;
with Freeze; use Freeze;
with Hostparm; use Hostparm; with Hostparm; use Hostparm;
with Inline; use Inline; with Inline; use Inline;
with Nlists; use Nlists; with Nlists; use Nlists;
...@@ -365,6 +366,7 @@ package body Exp_Ch4 is ...@@ -365,6 +366,7 @@ package body Exp_Ch4 is
Exp : constant Node_Id := Expression (Expression (N)); Exp : constant Node_Id := Expression (Expression (N));
Indic : constant Node_Id := Subtype_Mark (Expression (N)); Indic : constant Node_Id := Subtype_Mark (Expression (N));
PtrT : constant Entity_Id := Etype (N); PtrT : constant Entity_Id := Etype (N);
DesigT : constant Entity_Id := Designated_Type (PtrT);
T : constant Entity_Id := Entity (Indic); T : constant Entity_Id := Entity (Indic);
Flist : Node_Id; Flist : Node_Id;
Node : Node_Id; Node : Node_Id;
...@@ -456,7 +458,7 @@ package body Exp_Ch4 is ...@@ -456,7 +458,7 @@ package body Exp_Ch4 is
-- body, so a run-time check is needed in general. -- body, so a run-time check is needed in general.
if Ada_Version >= Ada_05 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 not Scope_Suppress (Accessibility_Check)
and then and then
(Is_Class_Wide_Type (Etype (Exp)) (Is_Class_Wide_Type (Etype (Exp))
...@@ -539,7 +541,7 @@ package body Exp_Ch4 is ...@@ -539,7 +541,7 @@ package body Exp_Ch4 is
end; end;
end if; end if;
if Controlled_Type (Designated_Type (PtrT)) if Controlled_Type (DesigT)
and then Controlled_Type (T) and then Controlled_Type (T)
then then
declare declare
...@@ -629,14 +631,14 @@ package body Exp_Ch4 is ...@@ -629,14 +631,14 @@ package body Exp_Ch4 is
Rewrite (N, New_Reference_To (Temp, Loc)); Rewrite (N, New_Reference_To (Temp, Loc));
Analyze_And_Resolve (N, PtrT); 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 (Exp) = N_Allocator
and then Nkind (Expression (Exp)) /= N_Qualified_Expression and then Nkind (Expression (Exp)) /= N_Qualified_Expression
then then
-- Apply constraint to designated subtype indication -- Apply constraint to designated subtype indication
Apply_Constraint_Check (Expression (Exp), Apply_Constraint_Check (Expression (Exp),
Designated_Type (Designated_Type (PtrT)), Designated_Type (DesigT),
No_Sliding => True); No_Sliding => True);
if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
...@@ -663,12 +665,12 @@ package body Exp_Ch4 is ...@@ -663,12 +665,12 @@ package body Exp_Ch4 is
-- on the qualified expression does not allow sliding, -- on the qualified expression does not allow sliding,
-- but this check does (a relaxation from Ada 83). -- 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 and then not Subtypes_Statically_Match
(T, Designated_Type (PtrT)) (T, DesigT)
then then
Apply_Constraint_Check Apply_Constraint_Check
(Exp, Designated_Type (PtrT), No_Sliding => False); (Exp, DesigT, No_Sliding => False);
-- The nonsliding check should really be performed -- The nonsliding check should really be performed
-- (unconditionally) against the subtype of the -- (unconditionally) against the subtype of the
...@@ -677,8 +679,33 @@ package body Exp_Ch4 is ...@@ -677,8 +679,33 @@ package body Exp_Ch4 is
else else
Apply_Constraint_Check Apply_Constraint_Check
(Exp, Designated_Type (PtrT), No_Sliding => True); (Exp, DesigT, No_Sliding => True);
end if; 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; end if;
exception exception
...@@ -3854,13 +3881,6 @@ package body Exp_Ch4 is ...@@ -3854,13 +3881,6 @@ package body Exp_Ch4 is
begin begin
Binary_Op_Validity_Checks (N); 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 -- N / 1 = N for integer types
if Is_Integer_Type (Typ) if Is_Integer_Type (Typ)
...@@ -3951,7 +3971,7 @@ package body Exp_Ch4 is ...@@ -3951,7 +3971,7 @@ package body Exp_Ch4 is
Analyze_And_Resolve (Left_Opnd (N), Universal_Real); 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 elsif Is_Integer_Type (Typ) then
Apply_Divide_Check (N); Apply_Divide_Check (N);
...@@ -3963,6 +3983,12 @@ package body Exp_Ch4 is ...@@ -3963,6 +3983,12 @@ package body Exp_Ch4 is
then then
Error_Msg_CRT ("64-bit division", N); Error_Msg_CRT ("64-bit division", N);
end if; end if;
-- Deal with Vax_Float
elsif Vax_Float (Typ) then
Expand_Vax_Arith (N);
return;
end if; end if;
end Expand_N_Op_Divide; end Expand_N_Op_Divide;
...@@ -4023,7 +4049,7 @@ package body Exp_Ch4 is ...@@ -4023,7 +4049,7 @@ package body Exp_Ch4 is
begin begin
-- Per-object constrained selected components require special -- Per-object constrained selected components require special
-- attention. If the enclosing scope of the component is an -- 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 -- directly. This is why we use the two extra parameters of
-- the equality function of the enclosing Unchecked_Union. -- the equality function of the enclosing Unchecked_Union.
...@@ -4239,14 +4265,13 @@ package body Exp_Ch4 is ...@@ -4239,14 +4265,13 @@ package body Exp_Ch4 is
return False; return False;
end if; end if;
-- We only need to test one component
declare declare
Comp : Node_Id := First (Component_Items (Clist)); Comp : Node_Id := First (Component_Items (Clist));
begin begin
while Present (Comp) loop while Present (Comp) loop
-- One component is sufficent
if Component_Is_Unconstrained_UU (Comp) then if Component_Is_Unconstrained_UU (Comp) then
return True; return True;
end if; end if;
...@@ -4324,9 +4349,10 @@ package body Exp_Ch4 is ...@@ -4324,9 +4349,10 @@ package body Exp_Ch4 is
if Ekind (Typl) = E_Private_Type then if Ekind (Typl) = E_Private_Type then
Typl := Underlying_Type (Typl); Typl := Underlying_Type (Typl);
elsif Ekind (Typl) = E_Private_Subtype then elsif Ekind (Typl) = E_Private_Subtype then
Typl := Underlying_Type (Base_Type (Typl)); Typl := Underlying_Type (Base_Type (Typl));
else
null;
end if; end if;
-- It may happen in error situations that the underlying type is not -- It may happen in error situations that the underlying type is not
...@@ -4339,15 +4365,9 @@ package body Exp_Ch4 is ...@@ -4339,15 +4365,9 @@ package body Exp_Ch4 is
Typl := Base_Type (Typl); 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) -- 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 (Left_Opnd (N));
Adjust_Condition (Right_Opnd (N)); Adjust_Condition (Right_Opnd (N));
Set_Etype (N, Standard_Boolean); Set_Etype (N, Standard_Boolean);
...@@ -4551,11 +4571,18 @@ package body Exp_Ch4 is ...@@ -4551,11 +4571,18 @@ package body Exp_Ch4 is
end if; end if;
-- If we still have an equality comparison (i.e. it was not rewritten -- 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 if Nkind (N) = N_Op_Eq then
Rewrite_Comparison (N); Rewrite_Comparison (N);
end if; 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; end Expand_N_Op_Eq;
----------------------- -----------------------
...@@ -4870,11 +4897,7 @@ package body Exp_Ch4 is ...@@ -4870,11 +4897,7 @@ package body Exp_Ch4 is
begin begin
Binary_Op_Validity_Checks (N); Binary_Op_Validity_Checks (N);
if Vax_Float (Typ1) then if Is_Array_Type (Typ1) then
Expand_Vax_Comparison (N);
return;
elsif Is_Array_Type (Typ1) then
Expand_Array_Comparison (N); Expand_Array_Comparison (N);
return; return;
end if; end if;
...@@ -4887,6 +4910,13 @@ package body Exp_Ch4 is ...@@ -4887,6 +4910,13 @@ package body Exp_Ch4 is
end if; end if;
Rewrite_Comparison (N); 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; end Expand_N_Op_Ge;
-------------------- --------------------
...@@ -4902,11 +4932,7 @@ package body Exp_Ch4 is ...@@ -4902,11 +4932,7 @@ package body Exp_Ch4 is
begin begin
Binary_Op_Validity_Checks (N); Binary_Op_Validity_Checks (N);
if Vax_Float (Typ1) then if Is_Array_Type (Typ1) then
Expand_Vax_Comparison (N);
return;
elsif Is_Array_Type (Typ1) then
Expand_Array_Comparison (N); Expand_Array_Comparison (N);
return; return;
end if; end if;
...@@ -4919,6 +4945,13 @@ package body Exp_Ch4 is ...@@ -4919,6 +4945,13 @@ package body Exp_Ch4 is
end if; end if;
Rewrite_Comparison (N); 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; end Expand_N_Op_Gt;
-------------------- --------------------
...@@ -4934,11 +4967,7 @@ package body Exp_Ch4 is ...@@ -4934,11 +4967,7 @@ package body Exp_Ch4 is
begin begin
Binary_Op_Validity_Checks (N); Binary_Op_Validity_Checks (N);
if Vax_Float (Typ1) then if Is_Array_Type (Typ1) then
Expand_Vax_Comparison (N);
return;
elsif Is_Array_Type (Typ1) then
Expand_Array_Comparison (N); Expand_Array_Comparison (N);
return; return;
end if; end if;
...@@ -4951,6 +4980,13 @@ package body Exp_Ch4 is ...@@ -4951,6 +4980,13 @@ package body Exp_Ch4 is
end if; end if;
Rewrite_Comparison (N); 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; end Expand_N_Op_Le;
-------------------- --------------------
...@@ -4966,11 +5002,7 @@ package body Exp_Ch4 is ...@@ -4966,11 +5002,7 @@ package body Exp_Ch4 is
begin begin
Binary_Op_Validity_Checks (N); Binary_Op_Validity_Checks (N);
if Vax_Float (Typ1) then if Is_Array_Type (Typ1) then
Expand_Vax_Comparison (N);
return;
elsif Is_Array_Type (Typ1) then
Expand_Array_Comparison (N); Expand_Array_Comparison (N);
return; return;
end if; end if;
...@@ -4983,6 +5015,13 @@ package body Exp_Ch4 is ...@@ -4983,6 +5015,13 @@ package body Exp_Ch4 is
end if; end if;
Rewrite_Comparison (N); 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 Expand_N_Op_Lt;
----------------------- -----------------------
...@@ -5187,13 +5226,6 @@ package body Exp_Ch4 is ...@@ -5187,13 +5226,6 @@ package body Exp_Ch4 is
end if; end if;
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 -- 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 -- 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. -- operand is an integer, as required for this to work.
...@@ -5304,6 +5336,12 @@ package body Exp_Ch4 is ...@@ -5304,6 +5336,12 @@ package body Exp_Ch4 is
elsif Is_Signed_Integer_Type (Etype (N)) then elsif Is_Signed_Integer_Type (Etype (N)) then
Apply_Arithmetic_Overflow_Check (N); Apply_Arithmetic_Overflow_Check (N);
-- Deal with VAX float case
elsif Vax_Float (Typ) then
Expand_Vax_Arith (N);
return;
end if; end if;
end Expand_N_Op_Multiply; end Expand_N_Op_Multiply;
...@@ -5311,12 +5349,44 @@ package body Exp_Ch4 is ...@@ -5311,12 +5349,44 @@ package body Exp_Ch4 is
-- Expand_N_Op_Ne -- -- 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 procedure Expand_N_Op_Ne (N : Node_Id) is
Typ : constant Entity_Id := Etype (Left_Opnd (N));
begin
-- Case of elementary type with standard operator
if Is_Elementary_Type (Typ)
and then Sloc (Entity (N)) = Standard_Location
then
Binary_Op_Validity_Checks (N);
-- Boolean types (requiring handling of non-standard case)
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;
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); Loc : constant Source_Ptr := Sloc (N);
Neg : Node_Id; Neg : Node_Id;
Ne : constant Entity_Id := Entity (N); Ne : constant Entity_Id := Entity (N);
...@@ -5336,14 +5406,17 @@ package body Exp_Ch4 is ...@@ -5336,14 +5406,17 @@ package body Exp_Ch4 is
Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne)); Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
end if; end if;
-- For navigation purposes, the inequality is treated as an implicit -- For navigation purposes, the inequality is treated as an
-- reference to the corresponding equality. Preserve the Comes_From_ -- implicit reference to the corresponding equality. Preserve the
-- source flag so that the proper Xref entry is generated. -- Comes_From_ source flag so that the proper Xref entry is
-- generated.
Preserve_Comes_From_Source (Neg, N); Preserve_Comes_From_Source (Neg, N);
Preserve_Comes_From_Source (Right_Opnd (Neg), N); Preserve_Comes_From_Source (Right_Opnd (Neg), N);
Rewrite (N, Neg); Rewrite (N, Neg);
Analyze_And_Resolve (N, Standard_Boolean); Analyze_And_Resolve (N, Standard_Boolean);
end;
end if;
end Expand_N_Op_Ne; end Expand_N_Op_Ne;
--------------------- ---------------------
...@@ -6533,9 +6606,9 @@ package body Exp_Ch4 is ...@@ -6533,9 +6606,9 @@ package body Exp_Ch4 is
(Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc)); (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
Set_Etype (Conv, Btyp); Set_Etype (Conv, Btyp);
-- Enable overflow except in the case of integer to float -- Enable overflow except for case of integer to float conversions,
-- conversions, where it is never required, since we can -- where it is never required, since we can never have overflow in
-- never have overflow in this case. -- this case.
if not Is_Integer_Type (Etype (Operand)) then if not Is_Integer_Type (Etype (Operand)) then
Enable_Overflow_Check (Conv); Enable_Overflow_Check (Conv);
...@@ -6588,13 +6661,6 @@ package body Exp_Ch4 is ...@@ -6588,13 +6661,6 @@ package body Exp_Ch4 is
return; return;
end if; 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 -- Nothing to do if this is the second argument of read. This
-- is a "backwards" conversion that will be handled by the -- is a "backwards" conversion that will be handled by the
-- specialized code in attribute processing. -- specialized code in attribute processing.
...@@ -6881,7 +6947,7 @@ package body Exp_Ch4 is ...@@ -6881,7 +6947,7 @@ package body Exp_Ch4 is
-- this type with proper overflow checking, and so gigi is doing an -- this type with proper overflow checking, and so gigi is doing an
-- approximation of what is required by doing floating-point compares -- approximation of what is required by doing floating-point compares
-- with the end-point. But that can lose precision in some cases, and -- 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 -- helpful, but still does not catch all cases with 64-bit integers
-- on targets with only 64-bit floats ??? -- on targets with only 64-bit floats ???
...@@ -6889,11 +6955,11 @@ package body Exp_Ch4 is ...@@ -6889,11 +6955,11 @@ package body Exp_Ch4 is
Rewrite (Operand, Rewrite (Operand,
Make_Type_Conversion (Loc, Make_Type_Conversion (Loc,
Subtype_Mark => Subtype_Mark =>
New_Occurrence_Of (Standard_Long_Long_Float, Loc), New_Occurrence_Of (Universal_Real, Loc),
Expression => Expression =>
Relocate_Node (Operand))); Relocate_Node (Operand)));
Set_Etype (Operand, Standard_Long_Long_Float); Set_Etype (Operand, Universal_Real);
Enable_Range_Check (Operand); Enable_Range_Check (Operand);
Set_Do_Range_Check (Expression (Operand), False); Set_Do_Range_Check (Expression (Operand), False);
end if; end if;
...@@ -6986,11 +7052,6 @@ package body Exp_Ch4 is ...@@ -6986,11 +7052,6 @@ package body Exp_Ch4 is
elsif Is_Floating_Point_Type (Target_Type) then elsif Is_Floating_Point_Type (Target_Type) then
Real_Range_Check; Real_Range_Check;
-- The remaining cases require no front end processing
else
null;
end if; end if;
-- At this stage, either the conversion node has been transformed -- At this stage, either the conversion node has been transformed
...@@ -7065,6 +7126,16 @@ package body Exp_Ch4 is ...@@ -7065,6 +7126,16 @@ package body Exp_Ch4 is
end if; end if;
end; end;
end if; 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; end Expand_N_Type_Conversion;
----------------------------------- -----------------------------------
...@@ -7803,7 +7874,6 @@ package body Exp_Ch4 is ...@@ -7803,7 +7874,6 @@ package body Exp_Ch4 is
Statements => New_List (If_Stat))); Statements => New_List (If_Stat)));
return Func_Body; return Func_Body;
end Make_Array_Comparison_Op; end Make_Array_Comparison_Op;
--------------------------- ---------------------------
...@@ -7960,6 +8030,18 @@ package body Exp_Ch4 is ...@@ -7960,6 +8030,18 @@ package body Exp_Ch4 is
True_Result := Res in Compare_GE; True_Result := Res in Compare_GE;
False_Result := Res = LT; 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 => when N_Op_Gt =>
True_Result := Res = GT; True_Result := Res = GT;
False_Result := Res in Compare_LE; False_Result := Res in Compare_LE;
...@@ -7972,9 +8054,21 @@ package body Exp_Ch4 is ...@@ -7972,9 +8054,21 @@ package body Exp_Ch4 is
True_Result := Res in Compare_LE; True_Result := Res in Compare_LE;
False_Result := Res = GT; 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 => when N_Op_Ne =>
True_Result := Res = NE; True_Result := Res = NE or else Res = GT or else Res = LT;
False_Result := Res = LT or else Res = GT or else Res = EQ; False_Result := Res = EQ;
end case; end case;
if True_Result then if True_Result then
......
gcc/ada/prj-proc.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -1129,7 +1129,7 @@ package body Prj.Proc is ...@@ -1129,7 +1129,7 @@ package body Prj.Proc is
end loop; end loop;
end if; end if;
Success := Total_Errors_Detected <= 0; Success := Total_Errors_Detected = 0;
end Process; end Process;
------------------------------- -------------------------------
......
gcc/ada/s-mastop-tru64.adb
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- B o d y -- -- B o d y --
-- (Version for Alpha/Dec Unix) -- -- (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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -143,7 +143,7 @@ package body System.Machine_State_Operations is ...@@ -143,7 +143,7 @@ package body System.Machine_State_Operations is
Prf : constant System.Address := exc_lookup_function (Get_Code_Loc (M)); Prf : constant System.Address := exc_lookup_function (Get_Code_Loc (M));
begin begin
if (Prf = System.Null_Address) then if Prf = System.Null_Address then
c_set_code_loc (M, 0); c_set_code_loc (M, 0);
else else
exc_virtual_unwind (Prf, M); exc_virtual_unwind (Prf, M);
......
gcc/ada/s-taprop-solaris.adb
...@@ -1382,7 +1382,7 @@ package body System.Task_Primitives.Operations is ...@@ -1382,7 +1382,7 @@ package body System.Task_Primitives.Operations is
begin begin
-- Check that caller is abort-deferred -- Check that caller is abort-deferred
if Self_ID.Deferral_Level <= 0 then if Self_ID.Deferral_Level = 0 then
return False; return False;
end if; end if;
...@@ -1419,7 +1419,7 @@ package body System.Task_Primitives.Operations is ...@@ -1419,7 +1419,7 @@ package body System.Task_Primitives.Operations is
-- Check that caller is abort-deferred -- Check that caller is abort-deferred
if Self_ID.Deferral_Level <= 0 then if Self_ID.Deferral_Level = 0 then
return False; return False;
end if; end if;
...@@ -1498,7 +1498,7 @@ package body System.Task_Primitives.Operations is ...@@ -1498,7 +1498,7 @@ package body System.Task_Primitives.Operations is
begin begin
-- Check that caller is abort-deferred -- Check that caller is abort-deferred
if Self_ID.Deferral_Level <= 0 then if Self_ID.Deferral_Level = 0 then
return False; return False;
end if; end if;
...@@ -1617,7 +1617,7 @@ package body System.Task_Primitives.Operations is ...@@ -1617,7 +1617,7 @@ package body System.Task_Primitives.Operations is
-- Check that caller is abort-deferred -- Check that caller is abort-deferred
if Self_ID.Deferral_Level <= 0 then if Self_ID.Deferral_Level = 0 then
return False; return False;
end if; end if;
...@@ -1646,7 +1646,7 @@ package body System.Task_Primitives.Operations is ...@@ -1646,7 +1646,7 @@ package body System.Task_Primitives.Operations is
begin begin
-- Check that caller is abort-deferred -- Check that caller is abort-deferred
if Self_ID.Deferral_Level <= 0 then if Self_ID.Deferral_Level = 0 then
return False; return False;
end if; end if;
...@@ -1833,7 +1833,7 @@ package body System.Task_Primitives.Operations is ...@@ -1833,7 +1833,7 @@ package body System.Task_Primitives.Operations is
-- Check that caller is abort-deferred -- Check that caller is abort-deferred
if Self_ID.Deferral_Level <= 0 then if Self_ID.Deferral_Level = 0 then
return False; return False;
end if; end if;
......
gcc/ada/sem_prag.adb
...@@ -64,6 +64,7 @@ with Sem_Res; use Sem_Res; ...@@ -64,6 +64,7 @@ with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type; with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util; with Sem_Util; use Sem_Util;
with Sem_VFpt; use Sem_VFpt; with Sem_VFpt; use Sem_VFpt;
with Sem_Warn; use Sem_Warn;
with Stand; use Stand; with Stand; use Stand;
with Sinfo; use Sinfo; with Sinfo; use Sinfo;
with Sinfo.CN; use Sinfo.CN; with Sinfo.CN; use Sinfo.CN;
...@@ -236,8 +237,9 @@ package body Sem_Prag is ...@@ -236,8 +237,9 @@ package body Sem_Prag is
Pragma_Exit : exception; Pragma_Exit : exception;
-- This exception is used to exit pragma processing completely. It -- This exception is used to exit pragma processing completely. It
-- is used when an error is detected, and in other situations where -- is used when an error is detected, and no further processing is
-- it is known that no further processing is required. -- 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; Arg_Count : Nat;
-- Number of pragma argument associations -- Number of pragma argument associations
...@@ -1336,10 +1338,7 @@ package body Sem_Prag is ...@@ -1336,10 +1338,7 @@ package body Sem_Prag is
then then
Unit_Name := Defining_Entity (Unit_Node); Unit_Name := Defining_Entity (Unit_Node);
elsif Unit_Kind = N_Function_Instantiation elsif Unit_Kind in N_Generic_Instantiation then
or else Unit_Kind = N_Package_Instantiation
or else Unit_Kind = N_Procedure_Instantiation
then
Unit_Name := Defining_Entity (Unit_Node); Unit_Name := Defining_Entity (Unit_Node);
else else
...@@ -3784,9 +3783,21 @@ package body Sem_Prag is ...@@ -3784,9 +3783,21 @@ package body Sem_Prag is
-- suppress check for any check id value. -- suppress check for any check id value.
if C = All_Checks then 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 for J in Scope_Suppress'Range loop
if J /= Elaboration_Check then
Scope_Suppress (J) := Suppress_Case; Scope_Suppress (J) := Suppress_Case;
end if;
end loop; end loop;
-- If not All_Checks, just set appropriate entry. Note that we
-- will set Elaboration_Check if this is explicitly specified.
else else
Scope_Suppress (C) := Suppress_Case; Scope_Suppress (C) := Suppress_Case;
end if; end if;
...@@ -4259,7 +4270,7 @@ package body Sem_Prag is ...@@ -4259,7 +4270,7 @@ package body Sem_Prag is
if Warn_On_Unrecognized_Pragma then if Warn_On_Unrecognized_Pragma then
Error_Pragma ("unrecognized pragma%!?"); Error_Pragma ("unrecognized pragma%!?");
else else
raise Pragma_Exit; return;
end if; end if;
else else
Prag_Id := Get_Pragma_Id (Chars (N)); Prag_Id := Get_Pragma_Id (Chars (N));
...@@ -5991,7 +6002,7 @@ package body Sem_Prag is ...@@ -5991,7 +6002,7 @@ package body Sem_Prag is
Present (Source_Location) Present (Source_Location)
then then
Error_Pragma Error_Pragma
("parameter profile and source location can not " & ("parameter profile and source location cannot " &
"be used together in pragma%"); "be used together in pragma%");
end if; end if;
...@@ -8141,6 +8152,28 @@ package body Sem_Prag is ...@@ -8141,6 +8152,28 @@ package body Sem_Prag is
S : String_Id; S : String_Id;
Active : Boolean := True; 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 begin
GNAT_Pragma; GNAT_Pragma;
Check_At_Most_N_Arguments (2); Check_At_Most_N_Arguments (2);
...@@ -8153,6 +8186,7 @@ package body Sem_Prag is ...@@ -8153,6 +8186,7 @@ package body Sem_Prag is
if Present (Prev (N)) then if Present (Prev (N)) then
Subp := Prev (N); Subp := Prev (N);
Check_Obsolete_Subprogram;
-- Second possibility, stand alone subprogram declaration with the -- Second possibility, stand alone subprogram declaration with the
-- pragma immediately following the declaration. -- pragma immediately following the declaration.
...@@ -8161,25 +8195,22 @@ package body Sem_Prag is ...@@ -8161,25 +8195,22 @@ package body Sem_Prag is
and then Nkind (Parent (N)) = N_Compilation_Unit_Aux and then Nkind (Parent (N)) = N_Compilation_Unit_Aux
then then
Subp := Unit (Parent (Parent (N))); Subp := Unit (Parent (Parent (N)));
Check_Obsolete_Subprogram;
-- Any other possibility is a misplacement -- Only other possibility is library unit placement for package
else else
Subp := Empty; Subp := Find_Lib_Unit_Name;
end if;
-- Check correct placement
if Nkind (Subp) /= N_Subprogram_Declaration then if Ekind (Subp) /= E_Package
Error_Pragma and then Ekind (Subp) /= E_Generic_Package
("pragma% misplaced, must immediately " & then
"follow subprogram spec"); Check_Obsolete_Subprogram;
end if;
end if; end if;
-- If OK placement, acquire arguments -- If OK placement, acquire arguments
Subp := Defining_Entity (Subp);
if Arg_Count >= 1 then if Arg_Count >= 1 then
-- Deal with static string argument -- Deal with static string argument
...@@ -9907,8 +9938,7 @@ package body Sem_Prag is ...@@ -9907,8 +9938,7 @@ package body Sem_Prag is
("pragma% requires separate spec and must come before body"); ("pragma% requires separate spec and must come before body");
elsif Rep_Item_Too_Early (E, N) elsif Rep_Item_Too_Early (E, N)
or else or else Rep_Item_Too_Late (E, N)
Rep_Item_Too_Late (E, N)
then then
raise Pragma_Exit; raise Pragma_Exit;
...@@ -10346,16 +10376,58 @@ package body Sem_Prag is ...@@ -10346,16 +10376,58 @@ package body Sem_Prag is
-------------- --------------
-- pragma Warnings (On | Off, [LOCAL_NAME]) -- pragma Warnings (On | Off, [LOCAL_NAME])
-- pragma Warnings (static_string_EXPRESSION);
when Pragma_Warnings => Warnings : begin when Pragma_Warnings => Warnings : begin
GNAT_Pragma; GNAT_Pragma;
Check_At_Least_N_Arguments (1); Check_At_Least_N_Arguments (1);
Check_At_Most_N_Arguments (2);
Check_No_Identifiers; 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_Is_One_Of (Arg1, Name_On, Name_Off);
Check_Arg_Count (2); Check_Arg_Count (2);
...@@ -10390,8 +10462,8 @@ package body Sem_Prag is ...@@ -10390,8 +10462,8 @@ package body Sem_Prag is
return; return;
else else
loop loop
Set_Warnings_Off (E, Set_Warnings_Off
(Chars (Expression (Arg1)) = Name_Off)); (E, (Chars (Expression (Arg1)) = Name_Off));
if Is_Enumeration_Type (E) then if Is_Enumeration_Type (E) then
declare declare
...@@ -10410,6 +10482,10 @@ package body Sem_Prag is ...@@ -10410,6 +10482,10 @@ package body Sem_Prag is
end loop; end loop;
end if; end if;
end; end;
-- More than two arguments
else
Check_At_Most_N_Arguments (2);
end if; end if;
end Warnings; end Warnings;
......
gcc/ada/sem_prag.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -28,62 +28,62 @@ ...@@ -28,62 +28,62 @@
-- (logically this processing belongs in chapter 4) -- (logically this processing belongs in chapter 4)
with Types; use Types; with Types; use Types;
package Sem_Prag is package Sem_Prag is
procedure Analyze_Pragma (N : Node_Id); procedure Analyze_Pragma (N : Node_Id);
-- Analyze procedure for pragma reference node N -- Analyze procedure for pragma reference node N
function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean; function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean;
-- N is a pragma appearing in a configuration pragma file. Most -- N is a pragma appearing in a configuration pragma file. Most such
-- such pragmas are analyzed when the file is read, before parsing -- pragmas are analyzed when the file is read, before parsing and analyzing
-- and analyzing the main unit. However, the analysis of certain -- the main unit. However, the analysis of certain pragmas results in
-- pragmas results in adding information to the compiled main unit, -- adding information to the compiled main unit, and this cannot be done
-- and this cannot be done till the main unit is processed. Such -- till the main unit is processed. Such pragmas return True from this
-- pragmas return True from this function and in Frontend pragmas -- function and in Frontend pragmas where Delay_Config_Pragma_Analyze is
-- where Delay_Config_Pragma_Analyze is True have their analysis -- True have their analysis delayed until after the main program is parsed
-- delayed until after the main program is parsed and analyzed. -- and analyzed.
function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean; 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 -- 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 -- occurrence is a reference for the purposes of giving warnings about
-- about unreferenced variables. This function returns True if the -- unreferenced variables. This function returns True if the reference is
-- reference is not a reference from this point of view (e.g. the -- not a reference from this point of view (e.g. the occurrence in a pragma
-- occurrence in a pragma Pack) and False if it is a real reference -- Pack) and False if it is a real reference (e.g. the occcurrence in a
-- (e.g. the occcurrence in a pragma Export); -- pragma Export);
function Is_Pragma_String_Literal (Par : Node_Id) return Boolean; function Is_Pragma_String_Literal (Par : Node_Id) return Boolean;
-- Given an N_Pragma_Argument_Association node, Par, which has the form -- Given an N_Pragma_Argument_Association node, Par, which has the form of
-- of an operator symbol, determines whether or not it should be treated -- an operator symbol, determines whether or not it should be treated as an
-- as an string literal. This is called by Sem_Ch6.Analyze_Operator_Symbol. -- string literal. This is called by Sem_Ch6.Analyze_Operator_Symbol. If
-- If True is returned, the argument is converted to a string literal. 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 -- False is returned, then the argument is treated as an entity reference
-- to the operator. -- to the operator.
function Is_Config_Static_String (Arg : Node_Id) return Boolean; function Is_Config_Static_String (Arg : Node_Id) return Boolean;
-- This is called for a configuration pragma that requires either a -- This is called for a configuration pragma that requires either string
-- string literal or a concatenation of string literals. We cannot -- literal or a concatenation of string literals. We cannot use normal
-- use normal static string processing because it is too early in -- static string processing because it is too early in the case of the
-- the case of the pragma appearing in a configuration pragmas file. -- pragma appearing in a configuration pragmas file. If Arg is of an
-- If Arg is of an appropriate form, then this call obtains the string -- appropriate form, then this call obtains the string (doing any necessary
-- (doing any necessary concatenations) and places it in Name_Buffer, -- concatenations) and places it in Name_Buffer, setting Name_Len to its
-- setting Name_Len to its length, and then returns True. If it is -- length, and then returns True. If it is not of the correct form, then an
-- not of the correct form, then an appropriate error message is -- appropriate error message is posted, and False is returned.
-- posted, and False is returned.
procedure Process_Compilation_Unit_Pragmas (N : Node_Id); procedure Process_Compilation_Unit_Pragmas (N : Node_Id);
-- Called at the start of processing compilation unit N to deal with -- Called at the start of processing compilation unit N to deal with any
-- any special issues regarding pragmas. In particular, we have to -- special issues regarding pragmas. In particular, we have to deal with
-- deal with Suppress_All at this stage, since it appears after the -- Suppress_All at this stage, since it appears after the unit instead of
-- unit instead of before. -- before.
procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id); procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id);
-- This routine is used to set an encoded interface name. The node -- This routine is used to set an encoded interface name. The node S is an
-- S is an N_String_Literal node for the external name to be set, and -- N_String_Literal node for the external name to be set, and E is an
-- E is an entity whose Interface_Name field is to be set. In the -- entity whose Interface_Name field is to be set. In the normal case where
-- normal case where S contains a name that is a valid C identifier, -- S contains a name that is a valid C identifier, then S is simply set as
-- then S is simply set as the value of the Interface_Name. Otherwise -- the value of the Interface_Name. Otherwise it is encoded. See the body
-- it is encoded. See the body for details of the encoding. This -- for details of the encoding. This encoding is only done on VMS systems,
-- encoding is only done on VMS systems, since it seems pretty silly, -- since it seems pretty silly, but is needed to pass some dubious tests in
-- but is needed to pass some dubious tests in the test suite. -- the test suite.
end Sem_Prag; end Sem_Prag;
gcc/ada/switch-c.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -32,6 +32,7 @@ with Osint; use Osint; ...@@ -32,6 +32,7 @@ with Osint; use Osint;
with Opt; use Opt; with Opt; use Opt;
with Prepcomp; use Prepcomp; with Prepcomp; use Prepcomp;
with Validsw; use Validsw; with Validsw; use Validsw;
with Sem_Warn; use Sem_Warn;
with Stylesw; use Stylesw; with Stylesw; use Stylesw;
with System.WCh_Con; use System.WCh_Con; with System.WCh_Con; use System.WCh_Con;
...@@ -67,7 +68,7 @@ package body Switch.C is ...@@ -67,7 +68,7 @@ package body Switch.C is
-- Skip past the initial character (must be the switch character) -- Skip past the initial character (must be the switch character)
if Ptr = Max then if Ptr = Max then
raise Bad_Switch; Bad_Switch (C);
else else
Ptr := Ptr + 1; Ptr := Ptr + 1;
end if; end if;
...@@ -104,7 +105,7 @@ package body Switch.C is ...@@ -104,7 +105,7 @@ package body Switch.C is
Ptr := Ptr + 1; Ptr := Ptr + 1;
if Ptr > Max then if Ptr > Max then
raise Bad_Switch; Bad_Switch (C);
end if; end if;
-- Find out whether this is a -I- or regular -Ixxx switch -- Find out whether this is a -I- or regular -Ixxx switch
...@@ -179,7 +180,7 @@ package body Switch.C is ...@@ -179,7 +180,7 @@ package body Switch.C is
end if; end if;
end if; end if;
else else
raise Bad_Switch; Bad_Switch (C);
end if; end if;
when True => when True =>
...@@ -261,7 +262,7 @@ package body Switch.C is ...@@ -261,7 +262,7 @@ package body Switch.C is
Dot := True; Dot := True;
else else
raise Bad_Switch; Bad_Switch (C);
end if; end if;
end loop; end loop;
...@@ -289,7 +290,7 @@ package body Switch.C is ...@@ -289,7 +290,7 @@ package body Switch.C is
-- so we must always have a character after the e. -- so we must always have a character after the e.
if Ptr > Max then if Ptr > Max then
raise Bad_Switch; Bad_Switch (C);
end if; end if;
case Switch_Chars (Ptr) is case Switch_Chars (Ptr) is
...@@ -308,7 +309,7 @@ package body Switch.C is ...@@ -308,7 +309,7 @@ package body Switch.C is
end if; end if;
if Ptr > Max then if Ptr > Max then
raise Bad_Switch; Bad_Switch (C);
end if; end if;
declare declare
...@@ -351,7 +352,7 @@ package body Switch.C is ...@@ -351,7 +352,7 @@ package body Switch.C is
Ptr := Ptr + 1; Ptr := Ptr + 1;
if Ptr > Max then if Ptr > Max then
raise Bad_Switch; Bad_Switch (C);
end if; end if;
Add_Symbol_Definition (Switch_Chars (Ptr .. Max)); Add_Symbol_Definition (Switch_Chars (Ptr .. Max));
...@@ -378,7 +379,8 @@ package body Switch.C is ...@@ -378,7 +379,8 @@ package body Switch.C is
when 'I' => when 'I' =>
Ptr := Ptr + 1; 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) -- -gnatem (mapping file)
...@@ -394,7 +396,7 @@ package body Switch.C is ...@@ -394,7 +396,7 @@ package body Switch.C is
end if; end if;
if Ptr > Max then if Ptr > Max then
raise Bad_Switch; Bad_Switch (C);
end if; end if;
Mapping_File_Name := Mapping_File_Name :=
...@@ -415,7 +417,7 @@ package body Switch.C is ...@@ -415,7 +417,7 @@ package body Switch.C is
end if; end if;
if Ptr > Max then if Ptr > Max then
raise Bad_Switch; Bad_Switch (C);
end if; end if;
Preprocessing_Data_File := Preprocessing_Data_File :=
...@@ -446,7 +448,7 @@ package body Switch.C is ...@@ -446,7 +448,7 @@ package body Switch.C is
-- All other -gnate? switches are unassigned -- All other -gnate? switches are unassigned
when others => when others =>
raise Bad_Switch; Bad_Switch (C);
end case; end case;
-- -gnatE (dynamic elaboration checks) -- -gnatE (dynamic elaboration checks)
...@@ -502,7 +504,7 @@ package body Switch.C is ...@@ -502,7 +504,7 @@ package body Switch.C is
Warn_On_Unchecked_Conversion := True; Warn_On_Unchecked_Conversion := True;
Warn_On_Unrecognized_Pragma := True; Warn_On_Unrecognized_Pragma := True;
Set_Style_Check_Options ("3abcdefhiklmnprstu"); Set_Style_Check_Options ("3abcdefhiklmnprstux");
-- Processing for G switch -- Processing for G switch
...@@ -526,7 +528,7 @@ package body Switch.C is ...@@ -526,7 +528,7 @@ package body Switch.C is
when 'i' => when 'i' =>
if Ptr = Max then if Ptr = Max then
raise Bad_Switch; Bad_Switch (C);
end if; end if;
Ptr := Ptr + 1; Ptr := Ptr + 1;
...@@ -544,14 +546,15 @@ package body Switch.C is ...@@ -544,14 +546,15 @@ package body Switch.C is
Ptr := Ptr + 1; Ptr := Ptr + 1;
else else
raise Bad_Switch; Bad_Switch (C);
end if; end if;
-- Processing for k switch -- Processing for k switch
when 'k' => when 'k' =>
Ptr := Ptr + 1; 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 -- Processing for l switch
...@@ -570,7 +573,14 @@ package body Switch.C is ...@@ -570,7 +573,14 @@ package body Switch.C is
when 'm' => when 'm' =>
Ptr := Ptr + 1; 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 -- Processing for n switch
...@@ -603,7 +613,18 @@ package body Switch.C is ...@@ -603,7 +613,18 @@ package body Switch.C is
when 'p' => when 'p' =>
Ptr := Ptr + 1; 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; Validity_Checks_On := False;
Opt.Suppress_Checks := True; Opt.Suppress_Checks := True;
Opt.Enable_Overflow_Checks := False; Opt.Enable_Overflow_Checks := False;
...@@ -648,7 +669,7 @@ package body Switch.C is ...@@ -648,7 +669,7 @@ package body Switch.C is
List_Representation_Info_Mechanisms := True; List_Representation_Info_Mechanisms := True;
else else
raise Bad_Switch; Bad_Switch (C);
end if; end if;
Ptr := Ptr + 1; Ptr := Ptr + 1;
...@@ -687,7 +708,7 @@ package body Switch.C is ...@@ -687,7 +708,7 @@ package body Switch.C is
when 'T' => when 'T' =>
Ptr := Ptr + 1; Ptr := Ptr + 1;
Scan_Pos (Switch_Chars, Max, Ptr, Table_Factor); Scan_Pos (Switch_Chars, Max, Ptr, Table_Factor, C);
-- Processing for u switch -- Processing for u switch
...@@ -715,7 +736,7 @@ package body Switch.C is ...@@ -715,7 +736,7 @@ package body Switch.C is
Ptr := Ptr + 1; Ptr := Ptr + 1;
if Ptr > Max then if Ptr > Max then
raise Bad_Switch; Bad_Switch (C);
else else
declare declare
...@@ -726,7 +747,7 @@ package body Switch.C is ...@@ -726,7 +747,7 @@ package body Switch.C is
(Switch_Chars (Ptr .. Max), OK, Ptr); (Switch_Chars (Ptr .. Max), OK, Ptr);
if not OK then if not OK then
raise Bad_Switch; Bad_Switch (C);
end if; end if;
for Index in First_Char + 1 .. Max loop for Index in First_Char + 1 .. Max loop
...@@ -748,188 +769,17 @@ package body Switch.C is ...@@ -748,188 +769,17 @@ package body Switch.C is
Ptr := Ptr + 1; Ptr := Ptr + 1;
if Ptr > Max then if Ptr > Max then
raise Bad_Switch; Bad_Switch (C);
end if; end if;
while Ptr <= Max loop while Ptr <= Max loop
C := Switch_Chars (Ptr); C := Switch_Chars (Ptr);
case C is if Set_Warning_Switch (C) then
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; null;
else
when others => Bad_Switch (C);
raise Bad_Switch; end if;
end case;
if C /= 'w' then if C /= 'w' then
Storing (First_Stored + 1) := C; Storing (First_Stored + 1) := C;
...@@ -948,7 +798,7 @@ package body Switch.C is ...@@ -948,7 +798,7 @@ package body Switch.C is
Ptr := Ptr + 1; Ptr := Ptr + 1;
if Ptr > Max then if Ptr > Max then
raise Bad_Switch; Bad_Switch (C);
end if; end if;
for J in WC_Encoding_Method loop for J in WC_Encoding_Method loop
...@@ -957,7 +807,7 @@ package body Switch.C is ...@@ -957,7 +807,7 @@ package body Switch.C is
exit; exit;
elsif J = WC_Encoding_Method'Last then elsif J = WC_Encoding_Method'Last then
raise Bad_Switch; Bad_Switch (C);
end if; end if;
end loop; end loop;
...@@ -1002,7 +852,7 @@ package body Switch.C is ...@@ -1002,7 +852,7 @@ package body Switch.C is
(Switch_Chars (Ptr .. Max), OK, Ptr); (Switch_Chars (Ptr .. Max), OK, Ptr);
if not OK then if not OK then
raise Bad_Switch; Bad_Switch (C);
end if; end if;
Ptr := First_Char + 1; Ptr := First_Char + 1;
...@@ -1047,7 +897,7 @@ package body Switch.C is ...@@ -1047,7 +897,7 @@ package body Switch.C is
Distribution_Stub_Mode := Generate_Caller_Stub_Body; Distribution_Stub_Mode := Generate_Caller_Stub_Body;
when others => when others =>
raise Bad_Switch; Bad_Switch (C);
end case; end case;
Ptr := Ptr + 1; Ptr := Ptr + 1;
...@@ -1065,13 +915,13 @@ package body Switch.C is ...@@ -1065,13 +915,13 @@ package body Switch.C is
when '8' => when '8' =>
if Ptr = Max then if Ptr = Max then
raise Bad_Switch; Bad_Switch (C);
end if; end if;
Ptr := Ptr + 1; Ptr := Ptr + 1;
if Switch_Chars (Ptr) /= '3' then if Switch_Chars (Ptr) /= '3' then
raise Bad_Switch; Bad_Switch (C);
else else
Ptr := Ptr + 1; Ptr := Ptr + 1;
Ada_Version := Ada_83; Ada_Version := Ada_83;
...@@ -1082,13 +932,13 @@ package body Switch.C is ...@@ -1082,13 +932,13 @@ package body Switch.C is
when '9' => when '9' =>
if Ptr = Max then if Ptr = Max then
raise Bad_Switch; Bad_Switch (C);
end if; end if;
Ptr := Ptr + 1; Ptr := Ptr + 1;
if Switch_Chars (Ptr) /= '5' then if Switch_Chars (Ptr) /= '5' then
raise Bad_Switch; Bad_Switch (C);
else else
Ptr := Ptr + 1; Ptr := Ptr + 1;
Ada_Version := Ada_95; Ada_Version := Ada_95;
...@@ -1099,13 +949,13 @@ package body Switch.C is ...@@ -1099,13 +949,13 @@ package body Switch.C is
when '0' => when '0' =>
if Ptr = Max then if Ptr = Max then
raise Bad_Switch; Bad_Switch (C);
end if; end if;
Ptr := Ptr + 1; Ptr := Ptr + 1;
if Switch_Chars (Ptr) /= '5' then if Switch_Chars (Ptr) /= '5' then
raise Bad_Switch; Bad_Switch (C);
else else
Ptr := Ptr + 1; Ptr := Ptr + 1;
Ada_Version := Ada_05; Ada_Version := Ada_05;
...@@ -1120,7 +970,7 @@ package body Switch.C is ...@@ -1120,7 +970,7 @@ package body Switch.C is
-- Anything else is an error (illegal switch character) -- Anything else is an error (illegal switch character)
when others => when others =>
raise Bad_Switch; Bad_Switch (C);
end case; end case;
end case; end case;
...@@ -1133,17 +983,6 @@ package body Switch.C is ...@@ -1133,17 +983,6 @@ package body Switch.C is
First_Switch := False; First_Switch := False;
end loop; 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 Scan_Front_End_Switches;
end Switch.C; end Switch.C;
gcc/ada/types.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -311,14 +311,14 @@ package Types is ...@@ -311,14 +311,14 @@ package Types is
-- is in practice infinite and there is no need to check the range. -- is in practice infinite and there is no need to check the range.
Ureal_Low_Bound : constant := 500_000_000; Ureal_Low_Bound : constant := 500_000_000;
-- Low bound for Ureal values. -- Low bound for Ureal values
Ureal_High_Bound : constant := 599_999_999; Ureal_High_Bound : constant := 599_999_999;
-- Maximum number of Ureal values stored is 100_000_000 which is in -- Maximum number of Ureal values stored is 100_000_000 which is in
-- practice infinite so that no check is required. -- practice infinite so that no check is required.
Uint_Low_Bound : constant := 600_000_000; 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; Uint_Table_Start : constant := 2_000_000_000;
-- Location where table entries for universal integers start (see -- Location where table entries for universal integers start (see
...@@ -479,7 +479,7 @@ package Types is ...@@ -479,7 +479,7 @@ package Types is
-- are not valid. -- are not valid.
First_Elist_Id : constant Elist_Id := No_Elist + 1; 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 Id values are used to identify individual elements of an
-- element list (see package Elists for further details). -- element list (see package Elists for further details).
...@@ -696,12 +696,19 @@ package Types is ...@@ -696,12 +696,19 @@ package Types is
Tag_Check, Tag_Check,
All_Checks); 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 -- for pragma Suppress. It is used to represent current settings of scope
-- based suppress actions from pragma Suppress or command line settings. -- based suppress actions from pragma Suppress or command line settings.
type Suppress_Array is -- Note: when Suppress_Array (All_Checks) is True, then generally all other
array (Check_Id range Access_Check .. Tag_Check) of Boolean; -- 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); pragma Pack (Suppress_Array);
-- To add a new check type to GNAT, the following steps are required: -- To add a new check type to GNAT, the following steps are required:
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment