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

[multiple changes]

Browse Source 
2010-06-18  Thomas Quinot  <quinot@adacore.com>

	* sem_eval.adb (Test_In_Range): New subprogram, factoring duplicated
	code between...
	(Is_In_Range, Is_Out_Of_Range): Reimplement in terms of call to
	Test_In_Range.

2010-06-18  Robert Dewar  <dewar@adacore.com>

	* sprint.adb: Minor change in output format for expression wi actions.
	* par-ch3.adb: Minor code reorganization.  Minor reformatting.
	* sem_ch5.adb: Minor comment fix.

2010-06-18  Robert Dewar  <dewar@adacore.com>

	* debug.adb: New debug flag -gnatd.L to control
	Back_End_Handles_Limited_Types.
	* exp_ch4.adb (Expand_N_Conditional_Expression): Let back end handle
	limited case if Back_End_Handles_Limited_Types is True.
	(Expand_N_Conditional_Expression): Use N_Expression_With_Actions to
	simplify expansion if Use_Expression_With_Actions is True.
	* gnat1drv.adb (Adjust_Global_Switches): Set
	Back_End_Handles_Limited_Types.
	* opt.ads (Back_End_Handles_Limited_Types): New flag.

2010-06-18  Ed Schonberg  <schonberg@adacore.com>

	* sem_res.adb (Rewrite_Operator_As_Call): Do not rewrite user-defined
	intrinsic operator if expansion is not enabled, because in an
	instantiation the original operator must be present to verify the
	legality of the operation.

From-SVN: r160969
This commit is contained in:
Arnaud Charlet 2010-06-18 11:28:45 +02:00
parent e1be7706e0
commit 305caf424d
10 changed files with 475 additions and 298 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
gcc/ada/ChangeLog
View File

@ -1,3 +1,35 @@
2010-06-18 Thomas Quinot <quinot@adacore.com>
* sem_eval.adb (Test_In_Range): New subprogram, factoring duplicated
code between...
(Is_In_Range, Is_Out_Of_Range): Reimplement in terms of call to
Test_In_Range.
2010-06-18 Robert Dewar <dewar@adacore.com>
* sprint.adb: Minor change in output format for expression wi actions.
* par-ch3.adb: Minor code reorganization. Minor reformatting.
* sem_ch5.adb: Minor comment fix.
2010-06-18 Robert Dewar <dewar@adacore.com>
* debug.adb: New debug flag -gnatd.L to control
Back_End_Handles_Limited_Types.
* exp_ch4.adb (Expand_N_Conditional_Expression): Let back end handle
limited case if Back_End_Handles_Limited_Types is True.
(Expand_N_Conditional_Expression): Use N_Expression_With_Actions to
simplify expansion if Use_Expression_With_Actions is True.
* gnat1drv.adb (Adjust_Global_Switches): Set
Back_End_Handles_Limited_Types.
* opt.ads (Back_End_Handles_Limited_Types): New flag.
2010-06-18 Ed Schonberg <schonberg@adacore.com>
* sem_res.adb (Rewrite_Operator_As_Call): Do not rewrite user-defined
intrinsic operator if expansion is not enabled, because in an
instantiation the original operator must be present to verify the
legality of the operation.
2010-06-18 Robert Dewar <dewar@adacore.com>
* exp_disp.adb, sem_ch12.adb: Minor reformatting

9
gcc/ada/debug.adb
View File

@ -76,7 +76,7 @@ package body Debug is
-- dJ Output debugging trace info for JGNAT (Java VM version of GNAT)
-- dK Kill all error messages
-- dL Output trace information on elaboration checking
-- dM Asssume all variables are modified (no current values)
-- dM Assume all variables are modified (no current values)
-- dN No file name information in exception messages
-- dO Output immediate error messages
-- dP Do not check for controlled objects in preelaborable packages
@ -129,7 +129,7 @@ package body Debug is
-- d.I SCIL generation mode
-- d.J Parallel SCIL generation mode
-- d.K
-- d.L
-- d.L Depend on back end for limited types in conditional expressions
-- d.M
-- d.N
-- d.O Dump internal SCO tables
@ -567,6 +567,11 @@ package body Debug is
-- This means in particular not writing the same files under the
-- same directory.
-- d.L Normally the front end generates special expansion for conditional
-- expressions of a limited type. This debug flag removes this special
-- case expansion, leaving it up to the back end to handle conditional
-- expressions correctly.
-- d.O Dump internal SCO tables. Before outputting the SCO information to
-- the ALI file, the internal SCO tables (SCO_Table/SCO_Unit_Table)
-- are dumped for debugging purposes.

163
gcc/ada/exp_ch4.adb
View File

@ -3882,7 +3882,7 @@ package body Exp_Ch4 is
-- Expand_N_Conditional_Expression --
-------------------------------------
-- Expand into expression actions if then/else actions present
-- Deal with limited types and expression actions
procedure Expand_N_Conditional_Expression (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
@ -3898,26 +3898,11 @@ package body Exp_Ch4 is
P_Decl : Node_Id;
begin
-- If either then or else actions are present, then given:
-- If the type is limited or unconstrained, we expand as follows to
-- avoid any possibility of improper copies.
-- if cond then then-expr else else-expr end
-- we insert the following sequence of actions (using Insert_Actions):
-- Cnn : typ;
-- if cond then
-- <<then actions>>
-- Cnn := then-expr;
-- else
-- <<else actions>>
-- Cnn := else-expr
-- end if;
-- and replace the conditional expression by a reference to Cnn
-- If the type is limited or unconstrained, the above expansion is
-- not legal, because it involves either an uninitialized object
-- or an illegal assignment. Instead, we generate:
-- Note: it may be possible to avoid this special processing if the
-- back end uses its own mechanisms for handling by-reference types ???
-- type Ptr is access all Typ;
-- Cnn : Ptr;
@ -3931,7 +3916,12 @@ package body Exp_Ch4 is
-- and replace the conditional expresion by a reference to Cnn.all.
if Is_By_Reference_Type (Typ) then
-- This special case can be skipped if the back end handles limited
-- types properly and ensures that no incorrect copies are made.
if Is_By_Reference_Type (Typ)
and then not Back_End_Handles_Limited_Types
then
Cnn := Make_Temporary (Loc, 'C', N);
P_Decl :=
@ -3979,40 +3969,82 @@ package body Exp_Ch4 is
-- associated with either branch.
elsif Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
Cnn := Make_Temporary (Loc, 'C', N);
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Cnn,
Object_Definition => New_Occurrence_Of (Typ, Loc));
-- We have two approaches to handling this. If we are allowed to use
-- N_Expression_With_Actions, then we can just wrap the actions into
-- the appropriate expression.
New_If :=
Make_Implicit_If_Statement (N,
Condition => Relocate_Node (Cond),
if Use_Expression_With_Actions then
if Present (Then_Actions (N)) then
Rewrite (Thenx,
Make_Expression_With_Actions (Sloc (Thenx),
Actions => Then_Actions (N),
Expression => Relocate_Node (Thenx)));
Analyze_And_Resolve (Thenx, Typ);
end if;
Then_Statements => New_List (
Make_Assignment_Statement (Sloc (Thenx),
Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
Expression => Relocate_Node (Thenx))),
if Present (Else_Actions (N)) then
Rewrite (Elsex,
Make_Expression_With_Actions (Sloc (Elsex),
Actions => Else_Actions (N),
Expression => Relocate_Node (Elsex)));
Analyze_And_Resolve (Elsex, Typ);
end if;
Else_Statements => New_List (
Make_Assignment_Statement (Sloc (Elsex),
Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
Expression => Relocate_Node (Elsex))));
return;
Set_Assignment_OK (Name (First (Then_Statements (New_If))));
Set_Assignment_OK (Name (First (Else_Statements (New_If))));
-- if we can't use N_Expression_With_Actions nodes, then we insert
-- the following sequence of actions (using Insert_Actions):
New_N := New_Occurrence_Of (Cnn, Loc);
-- Cnn : typ;
-- if cond then
-- <<then actions>>
-- Cnn := then-expr;
-- else
-- <<else actions>>
-- Cnn := else-expr
-- end if;
-- and replace the conditional expression by a reference to Cnn
else
Cnn := Make_Temporary (Loc, 'C', N);
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Cnn,
Object_Definition => New_Occurrence_Of (Typ, Loc));
New_If :=
Make_Implicit_If_Statement (N,
Condition => Relocate_Node (Cond),
Then_Statements => New_List (
Make_Assignment_Statement (Sloc (Thenx),
Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
Expression => Relocate_Node (Thenx))),
Else_Statements => New_List (
Make_Assignment_Statement (Sloc (Elsex),
Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
Expression => Relocate_Node (Elsex))));
Set_Assignment_OK (Name (First (Then_Statements (New_If))));
Set_Assignment_OK (Name (First (Else_Statements (New_If))));
New_N := New_Occurrence_Of (Cnn, Loc);
end if;
-- If no actions then no expansion needed, gigi will handle it using
-- the same approach as a C conditional expression.
else
-- No expansion needed, gigi handles it like a C conditional
-- expression.
return;
end if;
-- Move the SLOC of the parent If statement to the newly created one and
-- Fall through here for either the limited expansion, or the case of
-- inserting actions for non-limited types. In both these cases, we must
-- move the SLOC of the parent If statement to the newly created one and
-- change it to the SLOC of the expression which, after expansion, will
-- correspond to what is being evaluated.
@ -4143,7 +4175,8 @@ package body Exp_Ch4 is
Analyze_And_Resolve (N, Rtyp);
Error_Msg_N ("?explicit membership test may be optimized away", N);
Error_Msg_N ("\?use ''Valid attribute instead", N);
Error_Msg_N -- CODEFIX
("\?use ''Valid attribute instead", N);
return;
end Substitute_Valid_Check;
@ -4267,8 +4300,10 @@ package body Exp_Ch4 is
if Lcheck = LT or else Ucheck = GT then
if Warn1 then
Error_Msg_N ("?range test optimized away", N);
Error_Msg_N ("\?value is known to be out of range", N);
Error_Msg_N -- CODEFIX???
("?range test optimized away", N);
Error_Msg_N -- CODEFIX???
("\?value is known to be out of range", N);
end if;
Rewrite (N,
@ -4283,8 +4318,10 @@ package body Exp_Ch4 is
elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
if Warn1 then
Error_Msg_N ("?range test optimized away", N);
Error_Msg_N ("\?value is known to be in range", N);
Error_Msg_N -- CODEFIX???
("?range test optimized away", N);
Error_Msg_N -- CODEFIX???
("\?value is known to be in range", N);
end if;
Rewrite (N,
@ -4300,8 +4337,10 @@ package body Exp_Ch4 is
elsif Lcheck in Compare_GE then
if Warn2 and then not In_Instance then
Error_Msg_N ("?lower bound test optimized away", Lo);
Error_Msg_N ("\?value is known to be in range", Lo);
Error_Msg_N -- CODEFIX???
("?lower bound test optimized away", Lo);
Error_Msg_N -- CODEFIX???
("\?value is known to be in range", Lo);
end if;
Rewrite (N,
@ -4318,8 +4357,10 @@ package body Exp_Ch4 is
elsif Ucheck in Compare_LE then
if Warn2 and then not In_Instance then
Error_Msg_N ("?upper bound test optimized away", Hi);
Error_Msg_N ("\?value is known to be in range", Hi);
Error_Msg_N -- CODEFIX???
("?upper bound test optimized away", Hi);
Error_Msg_N -- CODEFIX???
("\?value is known to be in range", Hi);
end if;
Rewrite (N,
@ -4343,25 +4384,25 @@ package body Exp_Ch4 is
-- Result is out of range for valid value
if Lcheck = LT or else Ucheck = GT then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("?value can only be in range if it is invalid", N);
-- Result is in range for valid value
elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("?value can only be out of range if it is invalid", N);
-- Lower bound check succeeds if value is valid
elsif Warn2 and then Lcheck in Compare_GE then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("?lower bound check only fails if it is invalid", Lo);
-- Upper bound check succeeds if value is valid
elsif Warn2 and then Ucheck in Compare_LE then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("?upper bound check only fails for invalid values", Hi);
end if;
end if;
@ -9692,7 +9733,7 @@ package body Exp_Ch4 is
and then Is_Integer_Type (Etype (Left_Opnd (N)))
and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("can never be greater than, could replace by ""'=""?", N);
Warning_Generated := True;
end if;
@ -9717,7 +9758,7 @@ package body Exp_Ch4 is
and then Is_Integer_Type (Etype (Left_Opnd (N)))
and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("can never be less than, could replace by ""'=""?", N);
Warning_Generated := True;
end if;
@ -9755,11 +9796,11 @@ package body Exp_Ch4 is
and then not In_Instance
then
if True_Result then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("condition can only be False if invalid values present?",
N);
elsif False_Result then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("condition can only be True if invalid values present?",
N);
end if;

24
gcc/ada/gnat1drv.adb
View File

@ -359,6 +359,30 @@ procedure Gnat1drv is
else
Use_Expression_With_Actions := False;
end if;
-- Set switch indicating if back end can handle limited types, and
-- guarantee that no incorrect copies are made (e.g. in the context
-- of a conditional expression).
-- Debug flag -gnatd.L decisively sets usage on
if Debug_Flag_Dot_XX then
Back_End_Handles_Limited_Types := True;
-- If no debug flag, usage off for AAMP, VM, SCIL cases
elsif AAMP_On_Target
or else VM_Target /= No_VM
or else Generate_SCIL
then
Back_End_Handles_Limited_Types := False;
-- Otherwise normal gcc back end, for now still turn flag off by
-- default, since we have not verified proper back end handling.
else
Back_End_Handles_Limited_Types := False;
end if;
end Adjust_Global_Switches;
--------------------

15
gcc/ada/opt.ads
View File

@ -172,6 +172,15 @@ package Opt is
-- also set true if certain Unchecked_Conversion instantiations require
-- checking based on annotated values.
Back_End_Handles_Limited_Types : Boolean;
-- This flag is set true if the back end can properly handle limited or
-- other by reference types, and avoid copies. If this flag is False, then
-- the front end does special expansion for conditional expressions to make
-- sure that no copy occurs. If the flag is True, then the expansion for
-- conditional expressions relies on the back end properly handling things.
-- Currently the default is False for all cases (set in gnat1drv). The
-- default can be modified using -gnatd.L (sets the flag True).
Bind_Alternate_Main_Name : Boolean := False;
-- GNATBIND
-- True if main should be called Alternate_Main_Name.all.
@ -1239,12 +1248,12 @@ package Opt is
-- Set to True if -h (-gnath for the compiler) switch encountered
-- requesting usage information
Use_Expression_With_Actions : Boolean := False;
Use_Expression_With_Actions : Boolean;
-- The N_Expression_With_Actions node has been introduced relatively
-- recently, and not all back ends are prepared to handle it yet. So
-- we use this flag to suppress its use during a transitional period.
-- Currently the default is False for all cases except the standard
-- GCC back end. The default can be modified using -gnatd.X/-gnatd.Y.
-- Currently the default is False for all cases (set in gnat1drv).
-- The default can be modified using -gnatd.X/-gnatd.Y.
Use_Pragma_Linker_Constructor : Boolean := False;
-- GNATBIND

130
gcc/ada/par-ch3.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -125,7 +125,7 @@ package body Ch3 is
elsif Nkind_In (N, N_In, N_Not_In)
and then Paren_Count (N) = 0
then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("|this expression must be parenthesized!", N);
Error_Msg_N
("\|since extensions (and set notation) are allowed", N);
@ -385,7 +385,8 @@ package body Ch3 is
Scan; -- past = used in place of IS
elsif Token = Tok_Renames then
Error_Msg_SC ("RENAMES should be IS");
Error_Msg_SC -- CODEFIX
("RENAMES should be IS");
Scan; -- past RENAMES used in place of IS
else
@ -440,7 +441,8 @@ package body Ch3 is
or else Token = Tok_Record
or else Token = Tok_Null
then
Error_Msg_AP ("TAGGED expected");
Error_Msg_AP -- CODEFIX???
("TAGGED expected");
end if;
end if;
@ -455,7 +457,8 @@ package body Ch3 is
-- Special check for misuse of Aliased
if Token = Tok_Aliased or else Token_Name = Name_Aliased then
Error_Msg_SC ("ALIASED not allowed in type definition");
Error_Msg_SC -- CODEFIX???
("ALIASED not allowed in type definition");
Scan; -- past ALIASED
end if;
@ -677,7 +680,8 @@ package body Ch3 is
elsif Abstract_Present
and then Prev_Token /= Tok_Tagged
then
Error_Msg_SP ("TAGGED expected");
Error_Msg_SP -- CODEFIX???
("TAGGED expected");
end if;
Typedef_Node := P_Record_Definition;
@ -812,7 +816,7 @@ package body Ch3 is
if Nkind (Typedef_Node) =
N_Derived_Type_Definition
then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("SYNCHRONIZED not allowed for record extension",
Typedef_Node);
else
@ -827,7 +831,8 @@ package body Ch3 is
else
if Token /= Tok_Interface then
Error_Msg_SC ("NEW or INTERFACE expected");
Error_Msg_SC -- CODEFIX???
("NEW or INTERFACE expected");
end if;
Typedef_Node :=
@ -918,7 +923,8 @@ package body Ch3 is
Set_Abstract_Present (Typedef_Node, Abstract_Present);
elsif Abstract_Present then
Error_Msg ("ABSTRACT not allowed here, ignored", Abstract_Loc);
Error_Msg -- CODEFIX???
("ABSTRACT not allowed here, ignored", Abstract_Loc);
end if;
Decl_Node := New_Node (N_Full_Type_Declaration, Type_Loc);
@ -972,7 +978,8 @@ package body Ch3 is
TF_Is;
if Token = Tok_New then
Error_Msg_SC ("NEW ignored (only allowed in type declaration)");
Error_Msg_SC -- CODEFIX
("NEW ignored (only allowed in type declaration)");
Scan; -- past NEW
end if;
@ -1034,11 +1041,13 @@ package body Ch3 is
end if;
else
Error_Msg_SP ("NULL expected");
Error_Msg_SP -- CODEFIX???
("NULL expected");
end if;
if Token = Tok_New then
Error_Msg ("`NOT NULL` comes after NEW, not before", Not_Loc);
Error_Msg -- CODEFIX???
("`NOT NULL` comes after NEW, not before", Not_Loc);
end if;
return True;
@ -1090,7 +1099,8 @@ package body Ch3 is
return Subtype_Mark;
else
if Not_Null_Present then
Error_Msg_SP ("`NOT NULL` not allowed if constraint given");
Error_Msg_SP -- CODEFIX???
("`NOT NULL` not allowed if constraint given");
end if;
Indic_Node := New_Node (N_Subtype_Indication, Sloc (Subtype_Mark));
@ -1358,8 +1368,9 @@ package body Ch3 is
procedure No_List is
begin
if Num_Idents > 1 then
Error_Msg ("identifier list not allowed for RENAMES",
Sloc (Idents (2)));
Error_Msg -- CODEFIX???
("identifier list not allowed for RENAMES",
Sloc (Idents (2)));
end if;
List_OK := False;
@ -1379,7 +1390,8 @@ package body Ch3 is
Check_Misspelling_Of (Tok_Renames);
if Token = Tok_Renames then
Error_Msg_SP ("|extra "":"" ignored");
Error_Msg_SP -- CODEFIX
("|extra "":"" ignored");
Scan; -- past RENAMES
return True;
else
@ -1433,7 +1445,8 @@ package body Ch3 is
Scan; -- past :=
if Token = Tok_Constant then
Error_Msg_SP ("colon expected");
Error_Msg_SP -- CODEFIX???
("colon expected");
else
Restore_Scan_State (Scan_State);
@ -1553,7 +1566,7 @@ package body Ch3 is
if Present (Init_Expr) then
if Not_Null_Present then
Error_Msg_SP
Error_Msg_SP -- CODEFIX???
("`NOT NULL` not allowed in numeric expression");
end if;
@ -1604,7 +1617,7 @@ package body Ch3 is
end if;
if Token = Tok_Renames then
Error_Msg
Error_Msg -- CODEFIX???
("CONSTANT not permitted in renaming declaration",
Con_Loc);
Scan; -- Past renames
@ -1720,7 +1733,7 @@ package body Ch3 is
if Token_Is_Renames then
if Ada_Version < Ada_05 then
Error_Msg_SP
Error_Msg_SP -- CODEFIX???
("`NOT NULL` not allowed in object renaming");
raise Error_Resync;
@ -1750,9 +1763,10 @@ package body Ch3 is
-- illegal
if Token_Is_Renames then
Error_Msg_N ("constraint not allowed in object renaming "
& "declaration",
Constraint (Object_Definition (Decl_Node)));
Error_Msg_N -- CODEFIX???
("constraint not allowed in object renaming "
& "declaration",
Constraint (Object_Definition (Decl_Node)));
raise Error_Resync;
end if;
end if;
@ -1812,7 +1826,7 @@ package body Ch3 is
-- a constraint on the Type_Node and renames, which is illegal
if Token_Is_Renames then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("constraint not allowed in object renaming declaration",
Constraint (Object_Definition (Decl_Node)));
raise Error_Resync;
@ -1965,7 +1979,8 @@ package body Ch3 is
end loop;
if Token /= Tok_With then
Error_Msg_SC ("WITH expected");
Error_Msg_SC -- CODEFIX???
("WITH expected");
raise Error_Resync;
end if;
end if;
@ -1981,7 +1996,7 @@ package body Ch3 is
T_With; -- past WITH or give error message
if Token = Tok_Limited then
Error_Msg_SC
Error_Msg_SC -- CODEFIX???
("LIMITED keyword not allowed in private extension");
Scan; -- ignore LIMITED
end if;
@ -2107,7 +2122,6 @@ package body Ch3 is
Range_Node : Node_Id;
Save_Loc : Source_Ptr;
-- Start of processing for P_Range_Or_Subtype_Mark
begin
@ -2170,6 +2184,11 @@ package body Ch3 is
return Expr_Node;
end if;
-- Simple expression case
elsif Expr_Form = EF_Simple and then Allow_Simple_Expression then
return Expr_Node;
-- Here we have some kind of error situation. Check for junk parens
-- then return what we have, caller will deal with other errors.
@ -2177,7 +2196,8 @@ package body Ch3 is
if Nkind (Expr_Node) in N_Subexpr
and then Paren_Count (Expr_Node) /= 0
then
Error_Msg ("|parentheses not allowed for subtype mark", Save_Loc);
Error_Msg -- CODEFIX???
("|parentheses not allowed for subtype mark", Save_Loc);
Set_Paren_Count (Expr_Node, 0);
end if;
@ -2652,7 +2672,8 @@ package body Ch3 is
end if;
if Aliased_Present then
Error_Msg_SP ("ALIASED not allowed here");
Error_Msg_SP -- CODEFIX???
("ALIASED not allowed here");
end if;
Set_Subtype_Indication (CompDef_Node, Empty);
@ -3299,7 +3320,8 @@ package body Ch3 is
if Token = Tok_Colon then
Restore_Scan_State (Scan_State);
Error_Msg_SC ("component may not follow variant part");
Error_Msg_SC -- CODEFIX???
("component may not follow variant part");
Discard_Junk_Node (P_Component_List);
elsif Token = Tok_Case then
@ -3392,7 +3414,8 @@ package body Ch3 is
Set_Defining_Identifier (Decl_Node, Idents (Ident));
if Token = Tok_Constant then
Error_Msg_SC ("constant components are not permitted");
Error_Msg_SC -- CODEFIX???
("constant components are not permitted");
Scan;
end if;
@ -3420,7 +3443,8 @@ package body Ch3 is
end if;
if Aliased_Present then
Error_Msg_SP ("ALIASED not allowed here");
Error_Msg_SP -- CODEFIX???
("ALIASED not allowed here");
end if;
Set_Subtype_Indication (CompDef_Node, Empty);
@ -3434,7 +3458,7 @@ package body Ch3 is
Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
if Token = Tok_Array then
Error_Msg_SC
Error_Msg_SC -- CODEFIX???
("anonymous arrays not allowed as components");
raise Error_Resync;
end if;
@ -3514,7 +3538,8 @@ package body Ch3 is
Error_Msg ("discriminant name expected", Sloc (Case_Node));
elsif Paren_Count (Case_Node) /= 0 then
Error_Msg ("|discriminant name may not be parenthesized",
Error_Msg -- CODEFIX???
("|discriminant name may not be parenthesized",
Sloc (Case_Node));
Set_Paren_Count (Case_Node, 0);
end if;
@ -3698,7 +3723,8 @@ package body Ch3 is
end if;
if Token = Tok_Comma then
Error_Msg_SC (""","" should be ""'|""");
Error_Msg_SC -- CODEFIX
(""","" should be ""'|""");
else
exit when Token /= Tok_Vertical_Bar;
end if;
@ -3745,8 +3771,9 @@ package body Ch3 is
end if;
if Abstract_Present then
Error_Msg_SP ("ABSTRACT not allowed in interface type definition " &
"(RM 3.9.4(2/2))");
Error_Msg_SP -- CODEFIX???
("ABSTRACT not allowed in interface type definition " &
"(RM 3.9.4(2/2))");
end if;
Scan; -- past INTERFACE
@ -3768,7 +3795,8 @@ package body Ch3 is
else
if Token /= Tok_And then
Error_Msg_AP ("AND expected");
Error_Msg_AP -- CODEFIX???
("AND expected");
else
Scan; -- past AND
end if;
@ -3854,7 +3882,8 @@ package body Ch3 is
Scan; -- past possible junk subprogram name
if Token = Tok_Left_Paren or else Token = Tok_Semicolon then
Error_Msg_SP ("unexpected subprogram name ignored");
Error_Msg_SP -- CODEFIX???
("unexpected subprogram name ignored");
return;
else
@ -4035,7 +4064,7 @@ package body Ch3 is
if Token = Tok_All then
if Ada_Version < Ada_05 then
Error_Msg_SP
Error_Msg_SP -- CODEFIX???
("ALL is not permitted for anonymous access types");
end if;
@ -4246,7 +4275,8 @@ package body Ch3 is
when Tok_With =>
Check_Bad_Layout;
Error_Msg_SC ("WITH can only appear in context clause");
Error_Msg_SC -- CODEFIX???
("WITH can only appear in context clause");
raise Error_Resync;
-- BEGIN terminates the scan of a sequence of declarations unless
@ -4284,7 +4314,8 @@ package body Ch3 is
-- Otherwise we saved the semicolon position, so complain
else
Error_Msg ("|"";"" should be IS", SIS_Semicolon_Sloc);
Error_Msg -- CODEFIX
("|"";"" should be IS", SIS_Semicolon_Sloc);
end if;
-- The next job is to fix up any declarations that occurred
@ -4410,7 +4441,8 @@ package body Ch3 is
if In_Spec then
Done := True;
else
Error_Msg_SC ("PRIVATE not allowed in body");
Error_Msg_SC -- CODEFIX???
("PRIVATE not allowed in body");
Scan; -- past PRIVATE
end if;
@ -4519,17 +4551,17 @@ package body Ch3 is
Kind = N_Task_Body or else
Kind = N_Protected_Body
then
Error_Msg
Error_Msg -- CODEFIX???
("proper body not allowed in package spec", Sloc (Decl));
-- Test for body stub scanned, not acceptable as basic decl item
elsif Kind in N_Body_Stub then
Error_Msg
Error_Msg -- CODEFIX???
("body stub not allowed in package spec", Sloc (Decl));
elsif Kind = N_Assignment_Statement then
Error_Msg
Error_Msg -- CODEFIX???
("assignment statement not allowed in package spec",
Sloc (Decl));
end if;
@ -4618,7 +4650,8 @@ package body Ch3 is
-- not allowed in package spec. This message never gets changed.
if In_Spec then
Error_Msg_SC ("statement not allowed in package spec");
Error_Msg_SC -- CODEFIX???
("statement not allowed in package spec");
-- If in declarative part, then we give the message complaining
-- about finding a statement when a declaration is expected. This
@ -4626,7 +4659,8 @@ package body Ch3 is
-- find that no BEGIN is present.
else
Error_Msg_SC ("statement not allowed in declarative part");
Error_Msg_SC -- CODEFIX???
("statement not allowed in declarative part");
end if;
-- Capture message Id. This is used for two purposes, first to

28
gcc/ada/sem_ch5.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -558,7 +558,8 @@ package body Sem_Ch5 is
and then not Is_Tag_Indeterminate (Rhs)
and then not Is_Dynamically_Tagged (Rhs)
then
Error_Msg_N ("dynamically tagged expression required!", Rhs);
Error_Msg_N -- CODEFIX???
("dynamically tagged expression required!", Rhs);
end if;
-- Propagate the tag from a class-wide target to the rhs when the rhs
@ -572,7 +573,7 @@ package body Sem_Ch5 is
and then Is_Entity_Name (Name (Rhs))
and then Is_Abstract_Subprogram (Entity (Name (Rhs)))
then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("call to abstract function must be dispatching", Name (Rhs));
elsif Nkind (Rhs) = N_Qualified_Expression
@ -581,7 +582,7 @@ package body Sem_Ch5 is
and then
Is_Abstract_Subprogram (Entity (Name (Expression (Rhs))))
then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("call to abstract function must be dispatching",
Name (Expression (Rhs)));
end if;
@ -693,10 +694,10 @@ package body Sem_Ch5 is
and then Nkind (Original_Node (Rhs)) not in N_Op
then
if Nkind (Lhs) in N_Has_Entity then
Error_Msg_NE
Error_Msg_NE -- CODEFIX
("?useless assignment of & to itself!", N, Entity (Lhs));
else
Error_Msg_N
Error_Msg_N -- CODEFIX
("?useless assignment of object to itself!", N);
end if;
end if;
@ -948,7 +949,7 @@ package body Sem_Ch5 is
-- the case statement has a non static choice.
procedure Process_Statements (Alternative : Node_Id);
-- Analyzes all the statements associated to a case alternative.
-- Analyzes all the statements associated with a case alternative.
-- Needed by the generic instantiation below.
package Case_Choices_Processing is new
@ -1635,10 +1636,11 @@ package body Sem_Ch5 is
else
-- Both of them are user-defined
Error_Msg_N
Error_Msg_N -- CODEFIX???
("ambiguous bounds in range of iteration",
R_Copy);
Error_Msg_N ("\possible interpretations:", R_Copy);
Error_Msg_N -- CODEFIX???
("\possible interpretations:", R_Copy);
Error_Msg_NE ("\\} ", R_Copy, Found);
Error_Msg_NE ("\\} ", R_Copy, It.Typ);
exit;
@ -1890,7 +1892,7 @@ package body Sem_Ch5 is
if Compile_Time_Compare
(L, H, Assume_Valid => False) = GT
then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("?loop range is null, "
& "loop will not execute",
DS);
@ -1944,7 +1946,8 @@ package body Sem_Ch5 is
Intval (Original_Node (H)) = Uint_1)
then
Error_Msg_N ("?loop range may be null", DS);
Error_Msg_N ("\?bounds may be wrong way round", DS);
Error_Msg_N -- CODEFIX???
("\?bounds may be wrong way round", DS);
end if;
end;
end if;
@ -2241,7 +2244,8 @@ package body Sem_Ch5 is
-- Now issue the warning
Error_Msg ("?unreachable code!", Error_Loc);
Error_Msg -- CODEFIX???
("?unreachable code!", Error_Loc);
end if;
-- If the unconditional transfer of control instruction is

285
gcc/ada/sem_eval.adb
View File

@ -126,6 +126,10 @@ package body Sem_Eval is
-- This is the actual cache, with entries consisting of node/value pairs,
-- and the impossible value Node_High_Bound used for unset entries.
type Range_Membership is (In_Range, Out_Of_Range, Unknown);
-- Range membership may either be statically known to be in range or out
-- of range, or not statically known. Used for Test_In_Range below.
-----------------------
-- Local Subprograms --
-----------------------
@ -210,6 +214,18 @@ package body Sem_Eval is
-- Same processing, except applies to an expression N with two operands
-- Op1 and Op2.
function Test_In_Range
(N : Node_Id;
Typ : Entity_Id;
Assume_Valid : Boolean;
Fixed_Int : Boolean;
Int_Real : Boolean) return Range_Membership;
-- Common processing for Is_In_Range and Is_Out_Of_Range:
-- Returns In_Range or Out_Of_Range if it can be guaranteed at compile time
-- that expression N is known to be in or out of range of the subtype Typ.
-- If not compile time known, Unknown is returned.
-- See documentation of Is_In_Range for complete description of parameters.
procedure To_Bits (U : Uint; B : out Bits);
-- Converts a Uint value to a bit string of length B'Length
@ -3896,70 +3912,9 @@ package body Sem_Eval is
Fixed_Int : Boolean := False;
Int_Real : Boolean := False) return Boolean
is
Val : Uint;
Valr : Ureal;
pragma Warnings (Off, Assume_Valid);
-- For now Assume_Valid is unreferenced since the current implementation
-- always returns False if N is not a compile time known value, but we
-- keep the parameter to allow for future enhancements in which we try
-- to get the information in the variable case as well.
begin
-- Universal types have no range limits, so always in range
if Typ = Universal_Integer or else Typ = Universal_Real then
return True;
-- Never in range if not scalar type. Don't know if this can
-- actually happen, but our spec allows it, so we must check!
elsif not Is_Scalar_Type (Typ) then
return False;
-- Never in range unless we have a compile time known value
elsif not Compile_Time_Known_Value (N) then
return False;
-- General processing with a known compile time value
else
declare
Lo : Node_Id;
Hi : Node_Id;
LB_Known : Boolean;
UB_Known : Boolean;
begin
Lo := Type_Low_Bound (Typ);
Hi := Type_High_Bound (Typ);
LB_Known := Compile_Time_Known_Value (Lo);
UB_Known := Compile_Time_Known_Value (Hi);
-- Fixed point types should be considered as such only if flag
-- Fixed_Int is set to False.
if Is_Floating_Point_Type (Typ)
or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
or else Int_Real
then
Valr := Expr_Value_R (N);
return LB_Known and then Valr >= Expr_Value_R (Lo)
and then
UB_Known and then Valr <= Expr_Value_R (Hi);
else
Val := Expr_Value (N);
return LB_Known and then Val >= Expr_Value (Lo)
and then
UB_Known and then Val <= Expr_Value (Hi);
end if;
end;
end if;
return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real)
= In_Range;
end Is_In_Range;
-------------------
@ -4083,78 +4038,9 @@ package body Sem_Eval is
Fixed_Int : Boolean := False;
Int_Real : Boolean := False) return Boolean
is
Val : Uint;
Valr : Ureal;
pragma Warnings (Off, Assume_Valid);
-- For now Assume_Valid is unreferenced since the current implementation
-- always returns False if N is not a compile time known value, but we
-- keep the parameter to allow for future enhancements in which we try
-- to get the information in the variable case as well.
begin
-- Universal types have no range limits, so always in range
if Typ = Universal_Integer or else Typ = Universal_Real then
return False;
-- Never out of range if not scalar type. Don't know if this can
-- actually happen, but our spec allows it, so we must check!
elsif not Is_Scalar_Type (Typ) then
return False;
-- Never out of range if this is a generic type, since the bounds
-- of generic types are junk. Note that if we only checked for
-- static expressions (instead of compile time known values) below,
-- we would not need this check, because values of a generic type
-- can never be static, but they can be known at compile time.
elsif Is_Generic_Type (Typ) then
return False;
-- Never out of range unless we have a compile time known value
elsif not Compile_Time_Known_Value (N) then
return False;
else
declare
Lo : Node_Id;
Hi : Node_Id;
LB_Known : Boolean;
UB_Known : Boolean;
begin
Lo := Type_Low_Bound (Typ);
Hi := Type_High_Bound (Typ);
LB_Known := Compile_Time_Known_Value (Lo);
UB_Known := Compile_Time_Known_Value (Hi);
-- Real types (note that fixed-point types are not treated as
-- being of a real type if the flag Fixed_Int is set, since in
-- that case they are regarded as integer types).
if Is_Floating_Point_Type (Typ)
or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
or else Int_Real
then
Valr := Expr_Value_R (N);
return (LB_Known and then Valr < Expr_Value_R (Lo))
or else
(UB_Known and then Expr_Value_R (Hi) < Valr);
else
Val := Expr_Value (N);
return (LB_Known and then Val < Expr_Value (Lo))
or else
(UB_Known and then Expr_Value (Hi) < Val);
end if;
end;
end if;
return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real)
= Out_Of_Range;
end Is_Out_Of_Range;
---------------------
@ -4472,12 +4358,12 @@ package body Sem_Eval is
-- A constrained numeric subtype never matches an unconstrained
-- subtype, i.e. both types must be constrained or unconstrained.
-- To understand the requirement for this test, see RM 4.9.1(1). As
-- is made clear in RM 3.5.4(11), type Integer, for example is a
-- constrained subtype with constraint bounds matching the bounds of
-- its corresponding unconstrained base type. In this situation,
-- Integer and Integer'Base do not statically match, even though they
-- have the same bounds.
-- To understand the requirement for this test, see RM 4.9.1(1).
-- As is made clear in RM 3.5.4(11), type Integer, for example is
-- a constrained subtype with constraint bounds matching the bounds
-- of its corresponding unconstrained base type. In this situation,
-- Integer and Integer'Base do not statically match, even though
-- they have the same bounds.
-- We only apply this test to types in Standard and types that appear
-- in user programs. That way, we do not have to be too careful about
@ -4877,6 +4763,125 @@ package body Sem_Eval is
end if;
end Test_Expression_Is_Foldable;
-------------------
-- Test_In_Range --
-------------------
function Test_In_Range
(N : Node_Id;
Typ : Entity_Id;
Assume_Valid : Boolean;
Fixed_Int : Boolean;
Int_Real : Boolean) return Range_Membership
is
Val : Uint;
Valr : Ureal;
pragma Warnings (Off, Assume_Valid);
-- For now Assume_Valid is unreferenced since the current implementation
-- always returns Unknown if N is not a compile time known value, but we
-- keep the parameter to allow for future enhancements in which we try
-- to get the information in the variable case as well.
begin
-- Universal types have no range limits, so always in range
if Typ = Universal_Integer or else Typ = Universal_Real then
return In_Range;
-- Never known if not scalar type. Don't know if this can actually
-- happen, but our spec allows it, so we must check!
elsif not Is_Scalar_Type (Typ) then
return Unknown;
-- Never known if this is a generic type, since the bounds of generic
-- types are junk. Note that if we only checked for static expressions
-- (instead of compile time known values) below, we would not need this
-- check, because values of a generic type can never be static, but they
-- can be known at compile time.
elsif Is_Generic_Type (Typ) then
return Unknown;
-- Never known unless we have a compile time known value
elsif not Compile_Time_Known_Value (N) then
return Unknown;
-- General processing with a known compile time value
else
declare
Lo : Node_Id;
Hi : Node_Id;
LB_Known : Boolean;
HB_Known : Boolean;
begin
Lo := Type_Low_Bound (Typ);
Hi := Type_High_Bound (Typ);
LB_Known := Compile_Time_Known_Value (Lo);
HB_Known := Compile_Time_Known_Value (Hi);
-- Fixed point types should be considered as such only if flag
-- Fixed_Int is set to False.
if Is_Floating_Point_Type (Typ)
or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
or else Int_Real
then
Valr := Expr_Value_R (N);
if LB_Known and HB_Known then
if Valr >= Expr_Value_R (Lo)
and then
Valr <= Expr_Value_R (Hi)
then
return In_Range;
else
return Out_Of_Range;
end if;
elsif (LB_Known and then Valr < Expr_Value_R (Lo))
or else
(HB_Known and then Valr > Expr_Value_R (Hi))
then
return Out_Of_Range;
else
return Unknown;
end if;
else
Val := Expr_Value (N);
if LB_Known and HB_Known then
if Val >= Expr_Value (Lo)
and then
Val <= Expr_Value (Hi)
then
return In_Range;
else
return Out_Of_Range;
end if;
elsif (LB_Known and then Val < Expr_Value (Lo))
or else
(HB_Known and then Val > Expr_Value (Hi))
then
return Out_Of_Range;
else
return Unknown;
end if;
end if;
end;
end if;
end Test_In_Range;
--------------
-- To_Bits --
--------------

84
gcc/ada/sem_res.adb
View File

@ -214,7 +214,8 @@ package body Sem_Res is
-- to the corresponding predefined operator, with suitable conversions.
procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id);
-- Ditto, for unary operators (only arithmetic ones)
-- Ditto, for unary operators (arithmetic ones and "not" on signed
-- integer types for VMS).
procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id);
-- If an operator node resolves to a call to a user-defined operator,
@ -273,19 +274,20 @@ package body Sem_Res is
begin
if Nkind (C) = N_Character_Literal then
Error_Msg_N ("ambiguous character literal", C);
Error_Msg_N -- CODEFIX???
("ambiguous character literal", C);
-- First the ones in Standard
Error_Msg_N
Error_Msg_N -- CODEFIX???
("\\possible interpretation: Character!", C);
Error_Msg_N
Error_Msg_N -- CODEFIX???
("\\possible interpretation: Wide_Character!", C);
-- Include Wide_Wide_Character in Ada 2005 mode
if Ada_Version >= Ada_05 then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("\\possible interpretation: Wide_Wide_Character!", C);
end if;
@ -293,7 +295,8 @@ package body Sem_Res is
E := Current_Entity (C);
while Present (E) loop
Error_Msg_NE ("\\possible interpretation:}!", C, Etype (E));
Error_Msg_NE -- CODEFIX???
("\\possible interpretation:}!", C, Etype (E));
E := Homonym (E);
end loop;
end if;
@ -633,9 +636,10 @@ package body Sem_Res is
procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is
begin
if Is_Invisible_Operator (N, T) then
Error_Msg_NE
Error_Msg_NE -- CODEFIX
("operator for} is not directly visible!", N, First_Subtype (T));
Error_Msg_N ("use clause would make operation legal!", N);
Error_Msg_N -- CODEFIX
("use clause would make operation legal!", N);
end if;
end Check_For_Visible_Operator;
@ -1752,7 +1756,8 @@ package body Sem_Res is
and then Is_Entity_Name (Name (Arg))
and then Is_Overloaded (Name (Arg))
then
Error_Msg_NE ("ambiguous call to&", Arg, Name (Arg));
Error_Msg_NE -- CODEFIX???
("ambiguous call to&", Arg, Name (Arg));
-- Could use comments on what is going on here ???
@ -1761,9 +1766,11 @@ package body Sem_Res is
Error_Msg_Sloc := Sloc (It.Nam);
if Nkind (Parent (It.Nam)) = N_Full_Type_Declaration then
Error_Msg_N ("interpretation (inherited) #!", Arg);
Error_Msg_N -- CODEFIX???
("interpretation (inherited) #!", Arg);
else
Error_Msg_N ("interpretation #!", Arg);
Error_Msg_N -- CODEFIX???
("interpretation #!", Arg);
end if;
Get_Next_Interp (I, It);
@ -2058,7 +2065,7 @@ package body Sem_Res is
if Nkind (N) = N_Function_Call
and then Nkind (Name (N)) = N_Explicit_Dereference
then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("ambiguous expression "
& "(cannot resolve indirect call)!", N);
else
@ -2070,7 +2077,7 @@ package body Sem_Res is
Ambiguous := True;
if Nkind (Parent (Seen)) = N_Full_Type_Declaration then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("\\possible interpretation (inherited)#!", N);
else
Error_Msg_N -- CODEFIX
@ -2148,19 +2155,19 @@ package body Sem_Res is
if It.Typ = Universal_Fixed
and then Scope (It.Nam) = Standard_Standard
then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("\\possible interpretation as " &
"universal_fixed operation " &
"(RM 4.5.5 (19))", N);
else
Error_Msg_N
Error_Msg_N -- CODEFIX???
("\\possible interpretation (predefined)#!", N);
end if;
elsif
Nkind (Parent (It.Nam)) = N_Full_Type_Declaration
then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("\\possible interpretation (inherited)#!", N);
else
Error_Msg_N -- CODEFIX
@ -2908,7 +2915,7 @@ package body Sem_Res is
-- Introduce an implicit 'Access in prefix
if not Is_Aliased_View (Act) then
Error_Msg_NE
Error_Msg_NE -- CODEFIX???
("object in prefixed call to& must be aliased"
& " (RM-2005 4.3.1 (13))",
Prefix (Act), Nam);
@ -4199,7 +4206,8 @@ package body Sem_Res is
declare
Loc : constant Source_Ptr := Sloc (N);
begin
Error_Msg_N ("?allocation from empty storage pool!", N);
Error_Msg_N -- CODEFIX???
("?allocation from empty storage pool!", N);
Error_Msg_N ("\?Storage_Error will be raised at run time!", N);
Insert_Action (N,
Make_Raise_Storage_Error (Loc,
@ -6352,7 +6360,8 @@ package body Sem_Res is
and then Entity (R) = Standard_True
and then Comes_From_Source (R)
then
Error_Msg_N ("?comparison with True is redundant!", R);
Error_Msg_N -- CODEFIX
("?comparison with True is redundant!", R);
end if;
Check_Unset_Reference (L);
@ -6676,6 +6685,13 @@ package body Sem_Res is
Arg2 : Node_Id;
begin
-- We must preserve the original entity in a generic setting, so that
-- the legality of the operation can be verified in an instance.
if not Expander_Active then
return;
end if;
Op := Entity (N);
while Scope (Op) /= Standard_Standard loop
Op := Homonym (Op);
@ -7365,7 +7381,7 @@ package body Sem_Res is
elsif Typ = Universal_Integer or else Typ = Any_Modular then
if Parent_Is_Boolean then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("operand of not must be enclosed in parentheses",
Right_Opnd (N));
else
@ -7387,7 +7403,8 @@ package body Sem_Res is
and then not Is_Boolean_Type (Typ)
and then Parent_Is_Boolean
then
Error_Msg_N ("?not expression should be parenthesized here!", N);
Error_Msg_N -- CODEFIX???
("?not expression should be parenthesized here!", N);
end if;
-- Warn on double negation if checking redundant constructs
@ -7398,7 +7415,8 @@ package body Sem_Res is
and then Root_Type (Typ) = Standard_Boolean
and then Nkind (Right_Opnd (N)) = N_Op_Not
then
Error_Msg_N ("redundant double negation?", N);
Error_Msg_N -- CODEFIX???
("redundant double negation?", N);
end if;
-- Complete resolution and evaluation of NOT
@ -8578,7 +8596,8 @@ package body Sem_Res is
if From_With_Type (Opnd) then
Error_Msg_Qual_Level := 99;
Error_Msg_NE ("missing WITH clause on package &", N,
Error_Msg_NE -- CODEFIX
("missing WITH clause on package &", N,
Cunit_Entity (Get_Source_Unit (Base_Type (Opnd))));
Error_Msg_N
("type conversions require visibility of the full view",
@ -8590,7 +8609,8 @@ package body Sem_Res is
and then Present (Non_Limited_View (Etype (Target))))
then
Error_Msg_Qual_Level := 99;
Error_Msg_NE ("missing WITH clause on package &", N,
Error_Msg_NE -- CODEFIX
("missing WITH clause on package &", N,
Cunit_Entity (Get_Source_Unit (Base_Type (Target))));
Error_Msg_N
("type conversions require visibility of the full view",
@ -8682,7 +8702,7 @@ package body Sem_Res is
Determine_Range (Right_Opnd (N), OK, Lo, Hi);
if OK and then Hi >= Lo and then Lo >= 0 then
Error_Msg_N
Error_Msg_N -- CODEFIX
("?abs applied to known non-negative value has no effect", N);
end if;
end if;
@ -8820,7 +8840,7 @@ package body Sem_Res is
-- If we fall through warning should be issued
Error_Msg_N
Error_Msg_N -- CODEFIX???
("?unary minus expression should be parenthesized here!", N);
end if;
end if;
@ -9201,9 +9221,12 @@ package body Sem_Res is
procedure Fixed_Point_Error is
begin
Error_Msg_N ("ambiguous universal_fixed_expression", N);
Error_Msg_NE ("\\possible interpretation as}", N, T1);
Error_Msg_NE ("\\possible interpretation as}", N, T2);
Error_Msg_N -- CODEFIX???
("ambiguous universal_fixed_expression", N);
Error_Msg_NE -- CODEFIX???
("\\possible interpretation as}", N, T1);
Error_Msg_NE -- CODEFIX???
("\\possible interpretation as}", N, T2);
end Fixed_Point_Error;
-- Start of processing for Unique_Fixed_Point_Type
@ -10049,7 +10072,8 @@ package body Sem_Res is
and then Is_Access_Type (Opnd_Type)
then
Error_Msg_N ("target type must be general access type!", N);
Error_Msg_NE ("add ALL to }!", N, Target_Type);
Error_Msg_NE -- CODEFIX
("add ALL to }!", N, Target_Type);
return False;
else

3
gcc/ada/sprint.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -1513,7 +1513,6 @@ package body Sprint is
Indent_Begin;
Write_Indent_Str_Sloc ("do");
Indent_Begin;
Write_Indent;
Sprint_Node_List (Actions (Node));
Indent_End;
Write_Indent;