+2009-06-22 Robert Dewar <dewar@adacore.com>
+
+ * sinput.adb, sinput.ads (Expr_First_Char, Expr_Last_Char): Replaced
+ by Sloc_Range.
+
+ * freeze.adb: Minor comment updates
+
+ * s-valrea.adb (Bad_Based_Value): New procedure
+ (Scan_Real): Raise exceptions with messages
+
+2009-06-22 Matthew Gingell <gingell@adacore.com>
+
+ * adaint.h: Complete previous change.
+
+2009-06-22 Thomas Quinot <quinot@adacore.com>
+
+ * exp_ch7.ads, exp_ch3.adb: Minor reformatting
+
+2009-06-22 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Check_Overriding_Indicator): When style checks are
+ enabled, emit warning when a non-controlling argument of the overriding
+ operation appears out of place vis-a-vis of the formal of the
+ overridden operation.
+
2009-06-22 Vincent Celier <celier@adacore.com>
* gnatcmd.adb (Check_Files): Close temporary files after all file names
#define FOPEN fopen
#define STAT stat
#define FSTAT fstat
+#define LSTAT lstat
#define STRUCT_STAT struct stat
#endif
-- Take a copy of Exp to ensure that later copies of this component
-- declaration in derived types see the original tree, not a node
-- rewritten during expansion of the init_proc. If the copy contains
- -- itypes, the scope of the new itypes is the init.proc being built.
+ -- itypes, the scope of the new itypes is the init_proc being built.
Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id);
end if;
-- Adjust the component if controlled except if it is an aggregate
- -- that will be expanded inline
+ -- that will be expanded inline.
if Kind = N_Qualified_Expression then
Kind := Nkind (Expression (N));
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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- --
-- E is an entity representing a controlled object, a controlled type or a
-- scope. If Ref is not empty, it is a reference to a controlled record,
-- the closest Final list is in the controller component of the record
- -- containing Ref otherwise this function returns a reference to the final
- -- list attached to the closest dynamic scope (that can be E itself)
+ -- containing Ref, otherwise this function returns a reference to the final
+ -- list attached to the closest dynamic scope (which can be E itself),
-- creating this final list if necessary.
function Has_New_Controlled_Component (E : Entity_Id) return Boolean;
and then Convention (E) = Convention_C
then
Error_Msg_N
- ("?& is a tagged type which does not "
+ ("?& involves a tagged type which does not "
& "correspond to any C type!", Formal);
-- Check wrong convention subprogram pointer
end if;
end if;
- -- VM functions returning unconstrained arrays are
- -- correctly handled with the .NET/JVM compilers. Don't
- -- display this warning in those cases.
+ -- Give warning for suspicous return of a result of an
+ -- unconstrained array type in a foreign convention
+ -- function.
- if Is_Array_Type (R_Type)
+ if Has_Foreign_Convention (E)
+
+ -- We are looking for a return of unconstrained array
+
+ and then Is_Array_Type (R_Type)
and then not Is_Constrained (R_Type)
+
+ -- Exclude imported routines, the warning does not
+ -- belong on the import, but on the routine definition.
+
and then not Is_Imported (E)
+
+ -- Exclude VM case, since both .NET and JVM can handle
+ -- return of unconstrained arrays without a problem.
+
and then VM_Target = No_VM
- and then Has_Foreign_Convention (E)
+
+ -- Check that general warning is enabled, and that it
+ -- is not suppressed for this particular case.
+
and then Warn_On_Export_Import
and then not Has_Warnings_Off (E)
and then not Has_Warnings_Off (R_Type)
elsif Is_Generic_Type (Etype (E)) then
null;
- -- VM functions returning unconstrained arrays are
- -- correctly handled with the .NET/JVM compilers. Don't
- -- display this warning in those cases.
+ -- Display warning if returning unconstrained array
elsif Is_Array_Type (Retype)
and then not Is_Constrained (Retype)
+
+ -- Exclude cases where descriptor mechanism is set, since the
+ -- VMS descriptor mechanisms allow such unconstrained returns.
+
and then Mechanism (E) not in Descriptor_Codes
+
+ -- Check appropriate warning is enabled (should we check for
+ -- Warnings (Off) on specific entities here, probably so???)
+
and then Warn_On_Export_Import
+
+ -- Exclude the VM case, since return of unconstrained arrays
+ -- is properly handled in both the JVM and .NET cases.
+
and then VM_Target = No_VM
then
Error_Msg_N
end if;
end if;
- -- For VMS, descriptor mechanisms for parameters are allowed only
- -- for imported/exported subprograms. Moreover, the NCA descriptor
- -- is not allowed for parameters of exported subprograms.
+ -- For VMS, descriptor mechanisms for parameters are allowed only for
+ -- imported/exported subprograms. Moreover, the NCA descriptor is not
+ -- allowed for parameters of exported subprograms.
if OpenVMS_On_Target then
if Is_Exported (E) then
-- necessarily required in a case like this where the result is not
-- a machine number, but it is certainly a desirable behavior.
+ procedure Bad_Based_Value;
+ pragma No_Return (Bad_Based_Value);
+ -- Raise exception for bad based value
+
procedure Scanf;
-- Scans integer literal value starting at current character position.
-- For each digit encountered, Uval is multiplied by 10.0, and the new
-- return P points past the last character. On entry, the current
-- character is known to be a digit, so a numeral is definitely present.
+ ---------------------
+ -- Bad_Based_Value --
+ ---------------------
+
+ procedure Bad_Based_Value is
+ begin
+ raise Constraint_Error with
+ "invalid based literal for 'Value";
+ end Bad_Based_Value;
+
-----------
-- Scanf --
-----------
-- Any other initial character is an error
else
- raise Constraint_Error;
+ raise Constraint_Error with
+ "invalid character in 'Value string";
end if;
-- Deal with based case
loop
if P > Max then
- raise Constraint_Error;
+ Bad_Based_Value;
elsif Str (P) in Digs then
Digit := Character'Pos (Str (P)) - Character'Pos ('0');
Character'Pos (Str (P)) - (Character'Pos ('a') - 10);
else
- raise Constraint_Error;
+ Bad_Based_Value;
end if;
-- Save up trailing zeroes after the decimal point
P := P + 1;
if P > Max then
- raise Constraint_Error;
+ Bad_Based_Value;
elsif Str (P) = '_' then
Scan_Underscore (Str, P, Ptr, Max, True);
After_Point := 1;
if P > Max then
- raise Constraint_Error;
+ Bad_Based_Value;
end if;
end if;
-- Here is where we check for a bad based number
if Bad_Base then
- raise Constraint_Error;
+ Bad_Based_Value;
-- If OK, then deal with initial minus sign, note that this processing
-- is done even if Uval is zero, so that -0.0 is correctly interpreted.
return;
end if;
+ -- The overriding operation is type conformant with the overridden one,
+ -- but the names of the formals are not required to match. If the names
+ -- appear permuted in the overriding operation this is a possible
+ -- source of confusion that is worth diagnosing. Controlling formals
+ -- often carry names that reflect the type, and it is not worthwhile
+ -- requiring that their names match.
+
+ if Style_Check
+ and then Present (Overridden_Subp)
+ and then Nkind (Subp) /= N_Defining_Operator_Symbol
+ then
+ declare
+ Form1 : Entity_Id;
+ Form2 : Entity_Id;
+
+ begin
+ Form1 := First_Formal (Subp);
+ Form2 := First_Formal (Overridden_Subp);
+
+ if Present (Form1) then
+ Form1 := Next_Formal (Form1);
+ Form2 := Next_Formal (Form2);
+ end if;
+
+ while Present (Form1) loop
+ if not Is_Controlling_Formal (Form1)
+ and then Present (Next_Formal (Form2))
+ and then Chars (Form1) = Chars (Next_Formal (Form2))
+ then
+ Error_Msg_Node_2 := Alias (Overridden_Subp);
+ Error_Msg_Sloc := Sloc (Error_Msg_Node_2);
+ Error_Msg_NE ("& does not match corresponding formal of&#",
+ Form1, Form1);
+ exit;
+ end if;
+
+ Next_Formal (Form1);
+ Next_Formal (Form2);
+ end loop;
+ end;
+ end if;
+
if Present (Overridden_Subp) then
if Must_Not_Override (Spec) then
Error_Msg_Sloc := Sloc (Overridden_Subp);
with Opt; use Opt;
with Output; use Output;
with Tree_IO; use Tree_IO;
-with Sinfo; use Sinfo;
with System; use System;
with Widechar; use Widechar;
return;
end Build_Location_String;
- ---------------------
- -- Expr_First_Char --
- ---------------------
-
- function Expr_First_Char (Expr : Node_Id) return Source_Ptr is
-
- function First_Char (Expr : Node_Id; PC : Nat) return Source_Ptr;
- -- Internal recursive function used to traverse the expression tree.
- -- Returns the source pointer corresponding to the first location of
- -- the subexpression N, followed by backing up the given (PC) number of
- -- preceding left parentheses.
-
- ----------------
- -- First_Char --
- ----------------
-
- function First_Char (Expr : Node_Id; PC : Nat) return Source_Ptr is
- N : constant Node_Id := Original_Node (Expr);
- Count : constant Nat := PC + Paren_Count (N);
- Kind : constant N_Subexpr := Nkind (N);
- Loc : Source_Ptr;
-
- begin
- case Kind is
- when N_And_Then |
- N_In |
- N_Not_In |
- N_Or_Else |
- N_Binary_Op =>
- return First_Char (Left_Opnd (N), Count);
-
- when N_Attribute_Reference |
- N_Expanded_Name |
- N_Explicit_Dereference |
- N_Indexed_Component |
- N_Reference |
- N_Selected_Component |
- N_Slice =>
- return First_Char (Prefix (N), Count);
-
- when N_Function_Call =>
- return First_Char (Sinfo.Name (N), Count);
-
- when N_Qualified_Expression |
- N_Type_Conversion =>
- return First_Char (Subtype_Mark (N), Count);
-
- when N_Range =>
- return First_Char (Low_Bound (N), Count);
-
- -- Nodes that should not appear in original expression trees
-
- when N_Procedure_Call_Statement |
- N_Raise_xxx_Error |
- N_Subprogram_Info |
- N_Unchecked_Expression |
- N_Unchecked_Type_Conversion |
- N_Conditional_Expression =>
- raise Program_Error;
-
- -- Cases where the Sloc points to the start of the tokem, but we
- -- still need to handle the sequence of left parentheses.
-
- when N_Identifier |
- N_Operator_Symbol |
- N_Character_Literal |
- N_Integer_Literal |
- N_Null |
- N_Unary_Op |
- N_Aggregate |
- N_Allocator |
- N_Extension_Aggregate |
- N_Real_Literal |
- N_String_Literal =>
-
- Loc := Sloc (N);
-
- -- Skip past parens
-
- -- This is not right, it does not deal with skipping comments
- -- and probably also has wide character problems ???
-
- if Count > 0 then
- declare
- SFI : constant Source_File_Index :=
- Get_Source_File_Index (Loc);
- Src : constant Source_Buffer_Ptr := Source_Text (SFI);
- Fst : constant Source_Ptr := Source_First (SFI);
-
- begin
- for J in 1 .. Count loop
- loop
- exit when Loc = Fst;
- Loc := Loc - 1;
- exit when Src (Loc) >= ' ';
- end loop;
-
- exit when Src (Loc) /= '(';
- end loop;
- end;
- end if;
-
- return Loc;
- end case;
- end First_Char;
-
- -- Start of processing for Expr_First_Char
-
- begin
- pragma Assert (Nkind (Expr) in N_Subexpr);
- return First_Char (Expr, 0);
- end Expr_First_Char;
-
- --------------------
- -- Expr_Last_Char --
- --------------------
-
- function Expr_Last_Char (Expr : Node_Id) return Source_Ptr is
-
- function Last_Char (Expr : Node_Id; PC : Nat) return Source_Ptr;
- -- Internal recursive function used to traverse the expression tree.
- -- Returns the source pointer corresponding to the last location of
- -- the subexpression N, followed by ztepping to the last of the given
- -- number of right parentheses.
-
- ---------------
- -- Last_Char --
- ---------------
-
- function Last_Char (Expr : Node_Id; PC : Nat) return Source_Ptr is
- N : constant Node_Id := Original_Node (Expr);
- Count : constant Nat := PC + Paren_Count (N);
- Kind : constant N_Subexpr := Nkind (N);
- Loc : Source_Ptr;
-
- begin
- case Kind is
- when N_And_Then |
- N_In |
- N_Not_In |
- N_Or_Else |
- N_Binary_Op =>
- return Last_Char (Right_Opnd (N), Count);
-
- when N_Attribute_Reference |
- N_Expanded_Name |
- N_Explicit_Dereference |
- N_Indexed_Component |
- N_Reference |
- N_Selected_Component |
- N_Slice =>
- return Last_Char (Prefix (N), Count);
-
- when N_Function_Call =>
- return Last_Char (Sinfo.Name (N), Count);
-
- when N_Qualified_Expression |
- N_Type_Conversion =>
- return Last_Char (Subtype_Mark (N), Count);
-
- when N_Range =>
- return Last_Char (Low_Bound (N), Count);
-
- -- Nodes that should not appear in original expression trees
-
- when N_Procedure_Call_Statement |
- N_Raise_xxx_Error |
- N_Subprogram_Info |
- N_Unchecked_Expression |
- N_Unchecked_Type_Conversion |
- N_Conditional_Expression =>
- raise Program_Error;
-
- -- Cases where the Sloc points to the start of the token, but we
- -- still need to handle the sequence of left parentheses.
-
- when N_Identifier |
- N_Operator_Symbol |
- N_Character_Literal |
- N_Integer_Literal |
- N_Null |
- N_Unary_Op |
- N_Aggregate |
- N_Allocator |
- N_Extension_Aggregate |
- N_Real_Literal |
- N_String_Literal =>
-
- Loc := Sloc (N);
-
- -- Now we have two tasks, first we are pointing to the start
- -- of the token below, second, we need to skip parentheses.
-
- -- Skipping to the end of a token is not easy, we can't just
- -- skip to a space, since we may have e.g. X*YAR+Z, and if we
- -- are finding the end of the subexpression X*YAR, we don't
- -- want to skip past the +Z. Also we have to worry about
- -- skipping comments, and about wide characters ???
-
- declare
- SFI : constant Source_File_Index :=
- Get_Source_File_Index (Loc);
- Src : constant Source_Buffer_Ptr := Source_Text (SFI);
- Lst : constant Source_Ptr := Source_Last (SFI);
-
- begin
- -- Scan through first blank character, to get to the end
- -- of this token. As noted above that's not really right???
-
- loop
- exit when Loc = Lst or else Src (Loc + 1) <= ' ';
- Loc := Loc + 1;
- end loop;
-
- -- Skip past parens, but this also ignores comments ???
-
- if Count > 0 then
- for J in 1 .. Count loop
- loop
- exit when Loc = Lst;
- Loc := Loc + 1;
- exit when Src (Loc) >= ' ';
- end loop;
-
- exit when Src (Loc) /= ')';
- end loop;
- end if;
- end;
-
- return Loc;
- end case;
- end Last_Char;
-
- -- Start of processing for Expr_Last_Char
-
- begin
- pragma Assert (Nkind (Expr) in N_Subexpr);
- return Last_Char (Expr, 0);
- end Expr_Last_Char;
-
-----------------------
-- Get_Column_Number --
-----------------------
-----------------------------
function Get_Logical_Line_Number
- (P : Source_Ptr)
- return Logical_Line_Number
+ (P : Source_Ptr) return Logical_Line_Number
is
SFR : Source_File_Record
renames Source_File.Table (Get_Source_File_Index (P));
------------------------------
function Get_Physical_Line_Number
- (P : Source_Ptr)
- return Physical_Line_Number
+ (P : Source_Ptr) return Physical_Line_Number
is
Sfile : Source_File_Index;
Table : Lines_Table_Ptr;
begin
S := P;
-
while S > Sfirst
and then Src (S - 1) /= CR
and then Src (S - 1) /= LF
end Line_Start;
function Line_Start
- (L : Physical_Line_Number;
- S : Source_File_Index)
- return Source_Ptr
+ (L : Physical_Line_Number;
+ S : Source_File_Index) return Source_Ptr
is
begin
return Source_File.Table (S).Lines_Table (L);
function Physical_To_Logical
(Line : Physical_Line_Number;
- S : Source_File_Index)
- return Logical_Line_Number
+ S : Source_File_Index) return Logical_Line_Number
is
SFR : Source_File_Record renames Source_File.Table (S);
end;
end Skip_Line_Terminators;
+ ----------------
+ -- Sloc_Range --
+ ----------------
+
+ procedure Sloc_Range (Expr : Node_Id; Min, Max : out Source_Ptr) is
+
+ function Process (N : Node_Id) return Traverse_Result;
+ -- Process function for traversing the expression tree
+
+ procedure Traverse is new Traverse_Proc (Process);
+
+ -------------
+ -- Process --
+ -------------
+
+ function Process (N : Node_Id) return Traverse_Result is
+ begin
+ if Sloc (N) < Min then
+ if Sloc (N) > No_Location then
+ Min := Sloc (N);
+ end if;
+ elsif Sloc (N) > Max then
+ if Sloc (N) > No_Location then
+ Max := Sloc (N);
+ end if;
+ end if;
+
+ return OK;
+ end Process;
+
+ -- Start of processing for Sloc_Range
+
+ begin
+ Min := Sloc (Expr);
+ Max := Sloc (Expr);
+ Traverse (Expr);
+ end Sloc_Range;
+
-------------------
-- Source_Offset --
-------------------
Sindex : constant Source_File_Index := Get_Source_File_Index (S);
Sfirst : constant Source_Ptr :=
Source_File.Table (Sindex).Source_First;
-
begin
return Nat (S - Sfirst);
end Source_Offset;
else
return Source_File.Table (S).Source_Last;
end if;
-
end Source_Last;
function Source_Text (S : SFI) return Source_Buffer_Ptr is
else
return Source_File.Table (S).Source_Text;
end if;
-
end Source_Text;
function Template (S : SFI) return SFI is
-- ASCII.NUL, with Name_Length indicating the length not including the
-- terminating Nul.
- function Expr_First_Char (Expr : Node_Id) return Source_Ptr;
- -- Given a node for a subexpression, returns the source location of the
- -- first character of the expression.
-
- function Expr_Last_Char (Expr : Node_Id) return Source_Ptr;
- -- Given a node for a subexpression, returns the source location of the
- -- last character of the expression.
-
function Get_Column_Number (P : Source_Ptr) return Column_Number;
-- The ones-origin column number of the specified Source_Ptr value is
-- determined and returned. Tab characters if present are assumed to
procedure Skip_Line_Terminators
(P : in out Source_Ptr;
Physical : out Boolean);
- -- On entry, P points to a line terminator that has been encountered, which
- -- is one of FF,LF,VT,CR or a wide character sequence whose value is in
- -- category Separator,Line or Separator,Paragraph. P points just past the
- -- character that was scanned. The purpose of this routine is to
- -- distinguish physical and logical line endings. A physical line ending is
- -- one of:
+ -- On entry, P points to a line terminator that has been encountered,
+ -- which is one of FF,LF,VT,CR or a wide character sequence whose value is
+ -- in category Separator,Line or Separator,Paragraph. P points just past
+ -- the character that was scanned. The purpose of this routine is to
+ -- distinguish physical and logical line endings. A physical line ending
+ -- is one of:
--
-- CR on its own (MAC System 7)
-- LF on its own (Unix and unix-like systems)
-- makes sure that the lines table for the current source file has an
-- appropriate entry for the start of the new physical line.
+ procedure Sloc_Range (Expr : Node_Id; Min, Max : out Source_Ptr);
+ -- Given a node for a subexpression, returns the minimum and maximum source
+ -- locations of any node in the expression subtree. This is not quite the
+ -- same as the locations of the first and last token in the expresion
+ -- because parentheses at the outer level do not have a recorded Sloc.
+ --
+ -- Note: if the tree for the expression contains no "real" Sloc values,
+ -- i.e. values > No_Location, then both Min and Max are set to Sloc (Expr).
+
function Source_Offset (S : Source_Ptr) return Nat;
-- Returns the zero-origin offset of the given source location from the
-- start of its corresponding unit. This is used for creating canonical
OSDN Git Service
