From 116fd12714db033c74c10c95f86d536db5422c9c Mon Sep 17 00:00:00 2001 From: charlet Date: Mon, 22 Jun 2009 09:21:53 +0000 Subject: [PATCH] 2009-06-22 Robert Dewar * 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 * adaint.h: Complete previous change. 2009-06-22 Thomas Quinot * exp_ch7.ads, exp_ch3.adb: Minor reformatting 2009-06-22 Ed Schonberg * 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@148782 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 25 +++++ gcc/ada/adaint.h | 1 + gcc/ada/exp_ch3.adb | 4 +- gcc/ada/exp_ch7.ads | 6 +- gcc/ada/freeze.adb | 49 ++++++--- gcc/ada/s-valrea.adb | 27 +++-- gcc/ada/sem_ch6.adb | 42 ++++++++ gcc/ada/sinput.adb | 297 ++++++++------------------------------------------- gcc/ada/sinput.ads | 29 ++--- 9 files changed, 189 insertions(+), 291 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index bce68717b4b..80e21d13a5a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,28 @@ +2009-06-22 Robert Dewar + + * 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 + + * adaint.h: Complete previous change. + +2009-06-22 Thomas Quinot + + * exp_ch7.ads, exp_ch3.adb: Minor reformatting + +2009-06-22 Ed Schonberg + + * 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 * gnatcmd.adb (Check_Files): Close temporary files after all file names diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index a5243f1eef4..e8fb40bc4a9 100644 --- a/gcc/ada/adaint.h +++ b/gcc/ada/adaint.h @@ -58,6 +58,7 @@ #define FOPEN fopen #define STAT stat #define FSTAT fstat +#define LSTAT lstat #define STRUCT_STAT struct stat #endif diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index e8030d9c196..458f300b8dd 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1854,7 +1854,7 @@ package body Exp_Ch3 is -- 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); @@ -1885,7 +1885,7 @@ package body Exp_Ch3 is 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)); diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index b6c3ff26c24..a7c5cd7ba5a 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -75,8 +75,8 @@ package Exp_Ch7 is -- 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; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 5fc02c3608c..e68086cdc98 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -2451,7 +2451,7 @@ package body Freeze is 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 @@ -2600,15 +2600,30 @@ package body Freeze is 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) @@ -5047,14 +5062,24 @@ package body Freeze is 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 @@ -5084,9 +5109,9 @@ package body Freeze is 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 diff --git a/gcc/ada/s-valrea.adb b/gcc/ada/s-valrea.adb index 847777249e5..2e8306aabdc 100644 --- a/gcc/ada/s-valrea.adb +++ b/gcc/ada/s-valrea.adb @@ -89,6 +89,10 @@ package body System.Val_Real is -- 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 @@ -98,6 +102,16 @@ package body System.Val_Real is -- 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 -- ----------- @@ -181,7 +195,8 @@ package body System.Val_Real is -- 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 @@ -219,7 +234,7 @@ package body System.Val_Real is 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'); @@ -233,7 +248,7 @@ package body System.Val_Real is 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 @@ -267,7 +282,7 @@ package body System.Val_Real is P := P + 1; if P > Max then - raise Constraint_Error; + Bad_Based_Value; elsif Str (P) = '_' then Scan_Underscore (Str, P, Ptr, Max, True); @@ -282,7 +297,7 @@ package body System.Val_Real is After_Point := 1; if P > Max then - raise Constraint_Error; + Bad_Based_Value; end if; end if; @@ -358,7 +373,7 @@ package body System.Val_Real is -- 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. diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index b1f202c3652..d49ab79a43d 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -4374,6 +4374,48 @@ package body Sem_Ch6 is 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); diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb index 020e69df26d..9f5637d0a32 100644 --- a/gcc/ada/sinput.adb +++ b/gcc/ada/sinput.adb @@ -37,7 +37,6 @@ with Debug; use Debug; 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; @@ -240,246 +239,6 @@ package body Sinput is 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 -- ----------------------- @@ -525,8 +284,7 @@ package body Sinput is ----------------------------- 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)); @@ -546,8 +304,7 @@ package body Sinput is ------------------------------ 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; @@ -711,7 +468,6 @@ package body Sinput is begin S := P; - while S > Sfirst and then Src (S - 1) /= CR and then Src (S - 1) /= LF @@ -723,9 +479,8 @@ package body Sinput is 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); @@ -794,8 +549,7 @@ package body Sinput is 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); @@ -935,6 +689,44 @@ package body Sinput is 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 -- ------------------- @@ -943,7 +735,6 @@ package body Sinput is 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; @@ -1368,7 +1159,6 @@ package body Sinput is else return Source_File.Table (S).Source_Last; end if; - end Source_Last; function Source_Text (S : SFI) return Source_Buffer_Ptr is @@ -1378,7 +1168,6 @@ package body Sinput is else return Source_File.Table (S).Source_Text; end if; - end Source_Text; function Template (S : SFI) return SFI is diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads index c679e24d84b..945d26e7d4a 100644 --- a/gcc/ada/sinput.ads +++ b/gcc/ada/sinput.ads @@ -471,14 +471,6 @@ package Sinput 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 @@ -571,12 +563,12 @@ package Sinput is 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) @@ -603,6 +595,15 @@ package Sinput is -- 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 -- 2.11.0