+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
-- 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
-- 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
-- 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.
-- 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);
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;
-- 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 :=
-- 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.
+
+ 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;
- New_If :=
- Make_Implicit_If_Statement (N,
- Condition => Relocate_Node (Cond),
+ 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;
- Then_Statements => New_List (
- Make_Assignment_Statement (Sloc (Thenx),
- Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
- Expression => Relocate_Node (Thenx))),
+ return;
- Else_Statements => New_List (
- Make_Assignment_Statement (Sloc (Elsex),
- Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
- Expression => Relocate_Node (Elsex))));
+ -- if we can't use N_Expression_With_Actions nodes, then we insert
+ -- the following sequence of actions (using Insert_Actions):
- Set_Assignment_OK (Name (First (Then_Statements (New_If))));
- Set_Assignment_OK (Name (First (Else_Statements (New_If))));
+ -- Cnn : typ;
+ -- if cond then
+ -- <<then actions>>
+ -- Cnn := then-expr;
+ -- else
+ -- <<else actions>>
+ -- Cnn := else-expr
+ -- end if;
- New_N := New_Occurrence_Of (Cnn, Loc);
+ -- and replace the conditional expression by a reference to Cnn
- else
- -- No expansion needed, gigi handles it like a C conditional
- -- expression.
+ 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
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.
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;
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,
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,
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,
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,
-- 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;
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;
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;
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;
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;
--------------------
-- 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.
-- 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
-- --
-- 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- --
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);
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
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;
-- 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;
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;
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
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 :=
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);
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;
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;
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));
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;
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
Scan; -- past :=
if Token = Tok_Constant then
- Error_Msg_SP ("colon expected");
+ Error_Msg_SP -- CODEFIX???
+ ("colon expected");
else
Restore_Scan_State (Scan_State);
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;
end if;
if Token = Tok_Renames then
- Error_Msg
+ Error_Msg -- CODEFIX???
("CONSTANT not permitted in renaming declaration",
Con_Loc);
Scan; -- Past renames
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;
-- 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;
-- 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;
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;
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;
Range_Node : Node_Id;
Save_Loc : Source_Ptr;
-
-- Start of processing for P_Range_Or_Subtype_Mark
begin
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.
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;
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);
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
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;
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);
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;
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;
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;
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
else
if Token /= Tok_And then
- Error_Msg_AP ("AND expected");
+ Error_Msg_AP -- CODEFIX???
+ ("AND expected");
else
Scan; -- past AND
end if;
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
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;
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
-- 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
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;
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;
-- 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
-- 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
-- --
-- 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- --
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
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
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;
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;
-- 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
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;
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);
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;
-- 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
-- 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 --
-----------------------
-- 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
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;
-------------------
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;
---------------------
-- 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
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 --
--------------
-- 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,
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;
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;
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;
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 ???
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);
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
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
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
-- 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);
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,
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);
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);
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
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
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
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",
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",
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;
-- 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;
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
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
-- --
-- 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- --
Indent_Begin;
Write_Indent_Str_Sloc ("do");
Indent_Begin;
- Write_Indent;
Sprint_Node_List (Actions (Node));
Indent_End;
Write_Indent;
OSDN Git Service
