Skip to content

R
riscv-gcc-1
Commit e7d72fb9 by Arnaud Charlet
Options

[multiple changes] 

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.

From-SVN: r148782
parent 03456e44
Showing with 188 additions and 290 deletions
gcc/ada/ChangeLog
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> 2009-06-22 Vincent Celier <celier@adacore.com>
* gnatcmd.adb (Check_Files): Close temporary files after all file names * gnatcmd.adb (Check_Files): Close temporary files after all file names
......
gcc/ada/adaint.h
...@@ -58,6 +58,7 @@ ...@@ -58,6 +58,7 @@
#define FOPEN fopen #define FOPEN fopen
#define STAT stat #define STAT stat
#define FSTAT fstat #define FSTAT fstat
#define LSTAT lstat
#define STRUCT_STAT struct stat #define STRUCT_STAT struct stat
#endif #endif
......
gcc/ada/exp_ch3.adb
...@@ -1854,7 +1854,7 @@ package body Exp_Ch3 is ...@@ -1854,7 +1854,7 @@ package body Exp_Ch3 is
-- Take a copy of Exp to ensure that later copies of this component -- Take a copy of Exp to ensure that later copies of this component
-- declaration in derived types see the original tree, not a node -- declaration in derived types see the original tree, not a node
-- rewritten during expansion of the init_proc. If the copy contains -- 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); Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id);
...@@ -1885,7 +1885,7 @@ package body Exp_Ch3 is ...@@ -1885,7 +1885,7 @@ package body Exp_Ch3 is
end if; end if;
-- Adjust the component if controlled except if it is an aggregate -- 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 if Kind = N_Qualified_Expression then
Kind := Nkind (Expression (N)); Kind := Nkind (Expression (N));
......
gcc/ada/exp_ch7.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -75,8 +75,8 @@ package Exp_Ch7 is ...@@ -75,8 +75,8 @@ package Exp_Ch7 is
-- E is an entity representing a controlled object, a controlled type or a -- 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, -- 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 -- the closest Final list is in the controller component of the record
-- containing Ref otherwise this function returns a reference to the final -- containing Ref, otherwise this function returns a reference to the final
-- list attached to the closest dynamic scope (that can be E itself) -- list attached to the closest dynamic scope (which can be E itself),
-- creating this final list if necessary. -- creating this final list if necessary.
function Has_New_Controlled_Component (E : Entity_Id) return Boolean; function Has_New_Controlled_Component (E : Entity_Id) return Boolean;
......
gcc/ada/freeze.adb
...@@ -2451,7 +2451,7 @@ package body Freeze is ...@@ -2451,7 +2451,7 @@ package body Freeze is
and then Convention (E) = Convention_C and then Convention (E) = Convention_C
then then
Error_Msg_N Error_Msg_N
("?& is a tagged type which does not " ("?& involves a tagged type which does not "
& "correspond to any C type!", Formal); & "correspond to any C type!", Formal);
-- Check wrong convention subprogram pointer -- Check wrong convention subprogram pointer
...@@ -2600,15 +2600,30 @@ package body Freeze is ...@@ -2600,15 +2600,30 @@ package body Freeze is
end if; end if;
end if; end if;
-- VM functions returning unconstrained arrays are -- Give warning for suspicous return of a result of an
-- correctly handled with the .NET/JVM compilers. Don't -- unconstrained array type in a foreign convention
-- display this warning in those cases. -- 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) 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) 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 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 Warn_On_Export_Import
and then not Has_Warnings_Off (E) and then not Has_Warnings_Off (E)
and then not Has_Warnings_Off (R_Type) and then not Has_Warnings_Off (R_Type)
...@@ -5047,14 +5062,24 @@ package body Freeze is ...@@ -5047,14 +5062,24 @@ package body Freeze is
elsif Is_Generic_Type (Etype (E)) then elsif Is_Generic_Type (Etype (E)) then
null; null;
-- VM functions returning unconstrained arrays are -- Display warning if returning unconstrained array
-- correctly handled with the .NET/JVM compilers. Don't
-- display this warning in those cases.
elsif Is_Array_Type (Retype) elsif Is_Array_Type (Retype)
and then not Is_Constrained (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 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 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 and then VM_Target = No_VM
then then
Error_Msg_N Error_Msg_N
...@@ -5084,9 +5109,9 @@ package body Freeze is ...@@ -5084,9 +5109,9 @@ package body Freeze is
end if; end if;
end if; end if;
-- For VMS, descriptor mechanisms for parameters are allowed only -- For VMS, descriptor mechanisms for parameters are allowed only for
-- for imported/exported subprograms. Moreover, the NCA descriptor -- imported/exported subprograms. Moreover, the NCA descriptor is not
-- is not allowed for parameters of exported subprograms. -- allowed for parameters of exported subprograms.
if OpenVMS_On_Target then if OpenVMS_On_Target then
if Is_Exported (E) then if Is_Exported (E) then
......
gcc/ada/s-valrea.adb
...@@ -89,6 +89,10 @@ package body System.Val_Real is ...@@ -89,6 +89,10 @@ package body System.Val_Real is
-- necessarily required in a case like this where the result is not -- necessarily required in a case like this where the result is not
-- a machine number, but it is certainly a desirable behavior. -- 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; procedure Scanf;
-- Scans integer literal value starting at current character position. -- Scans integer literal value starting at current character position.
-- For each digit encountered, Uval is multiplied by 10.0, and the new -- For each digit encountered, Uval is multiplied by 10.0, and the new
...@@ -98,6 +102,16 @@ package body System.Val_Real is ...@@ -98,6 +102,16 @@ package body System.Val_Real is
-- return P points past the last character. On entry, the current -- return P points past the last character. On entry, the current
-- character is known to be a digit, so a numeral is definitely present. -- 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 -- -- Scanf --
----------- -----------
...@@ -181,7 +195,8 @@ package body System.Val_Real is ...@@ -181,7 +195,8 @@ package body System.Val_Real is
-- Any other initial character is an error -- Any other initial character is an error
else else
raise Constraint_Error; raise Constraint_Error with
"invalid character in 'Value string";
end if; end if;
-- Deal with based case -- Deal with based case
...@@ -219,7 +234,7 @@ package body System.Val_Real is ...@@ -219,7 +234,7 @@ package body System.Val_Real is
loop loop
if P > Max then if P > Max then
raise Constraint_Error; Bad_Based_Value;
elsif Str (P) in Digs then elsif Str (P) in Digs then
Digit := Character'Pos (Str (P)) - Character'Pos ('0'); Digit := Character'Pos (Str (P)) - Character'Pos ('0');
...@@ -233,7 +248,7 @@ package body System.Val_Real is ...@@ -233,7 +248,7 @@ package body System.Val_Real is
Character'Pos (Str (P)) - (Character'Pos ('a') - 10); Character'Pos (Str (P)) - (Character'Pos ('a') - 10);
else else
raise Constraint_Error; Bad_Based_Value;
end if; end if;
-- Save up trailing zeroes after the decimal point -- Save up trailing zeroes after the decimal point
...@@ -267,7 +282,7 @@ package body System.Val_Real is ...@@ -267,7 +282,7 @@ package body System.Val_Real is
P := P + 1; P := P + 1;
if P > Max then if P > Max then
raise Constraint_Error; Bad_Based_Value;
elsif Str (P) = '_' then elsif Str (P) = '_' then
Scan_Underscore (Str, P, Ptr, Max, True); Scan_Underscore (Str, P, Ptr, Max, True);
...@@ -282,7 +297,7 @@ package body System.Val_Real is ...@@ -282,7 +297,7 @@ package body System.Val_Real is
After_Point := 1; After_Point := 1;
if P > Max then if P > Max then
raise Constraint_Error; Bad_Based_Value;
end if; end if;
end if; end if;
...@@ -358,7 +373,7 @@ package body System.Val_Real is ...@@ -358,7 +373,7 @@ package body System.Val_Real is
-- Here is where we check for a bad based number -- Here is where we check for a bad based number
if Bad_Base then if Bad_Base then
raise Constraint_Error; Bad_Based_Value;
-- If OK, then deal with initial minus sign, note that this processing -- 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. -- is done even if Uval is zero, so that -0.0 is correctly interpreted.
......
gcc/ada/sem_ch6.adb
...@@ -4374,6 +4374,48 @@ package body Sem_Ch6 is ...@@ -4374,6 +4374,48 @@ package body Sem_Ch6 is
return; return;
end if; 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 Present (Overridden_Subp) then
if Must_Not_Override (Spec) then if Must_Not_Override (Spec) then
Error_Msg_Sloc := Sloc (Overridden_Subp); Error_Msg_Sloc := Sloc (Overridden_Subp);
......
gcc/ada/sinput.adb
...@@ -37,7 +37,6 @@ with Debug; use Debug; ...@@ -37,7 +37,6 @@ with Debug; use Debug;
with Opt; use Opt; with Opt; use Opt;
with Output; use Output; with Output; use Output;
with Tree_IO; use Tree_IO; with Tree_IO; use Tree_IO;
with Sinfo; use Sinfo;
with System; use System; with System; use System;
with Widechar; use Widechar; with Widechar; use Widechar;
...@@ -240,246 +239,6 @@ package body Sinput is ...@@ -240,246 +239,6 @@ package body Sinput is
return; return;
end Build_Location_String; 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 -- -- Get_Column_Number --
----------------------- -----------------------
...@@ -525,8 +284,7 @@ package body Sinput is ...@@ -525,8 +284,7 @@ package body Sinput is
----------------------------- -----------------------------
function Get_Logical_Line_Number function Get_Logical_Line_Number
(P : Source_Ptr) (P : Source_Ptr) return Logical_Line_Number
return Logical_Line_Number
is is
SFR : Source_File_Record SFR : Source_File_Record
renames Source_File.Table (Get_Source_File_Index (P)); renames Source_File.Table (Get_Source_File_Index (P));
...@@ -546,8 +304,7 @@ package body Sinput is ...@@ -546,8 +304,7 @@ package body Sinput is
------------------------------ ------------------------------
function Get_Physical_Line_Number function Get_Physical_Line_Number
(P : Source_Ptr) (P : Source_Ptr) return Physical_Line_Number
return Physical_Line_Number
is is
Sfile : Source_File_Index; Sfile : Source_File_Index;
Table : Lines_Table_Ptr; Table : Lines_Table_Ptr;
...@@ -711,7 +468,6 @@ package body Sinput is ...@@ -711,7 +468,6 @@ package body Sinput is
begin begin
S := P; S := P;
while S > Sfirst while S > Sfirst
and then Src (S - 1) /= CR and then Src (S - 1) /= CR
and then Src (S - 1) /= LF and then Src (S - 1) /= LF
...@@ -724,8 +480,7 @@ package body Sinput is ...@@ -724,8 +480,7 @@ package body Sinput is
function Line_Start function Line_Start
(L : Physical_Line_Number; (L : Physical_Line_Number;
S : Source_File_Index) S : Source_File_Index) return Source_Ptr
return Source_Ptr
is is
begin begin
return Source_File.Table (S).Lines_Table (L); return Source_File.Table (S).Lines_Table (L);
...@@ -794,8 +549,7 @@ package body Sinput is ...@@ -794,8 +549,7 @@ package body Sinput is
function Physical_To_Logical function Physical_To_Logical
(Line : Physical_Line_Number; (Line : Physical_Line_Number;
S : Source_File_Index) S : Source_File_Index) return Logical_Line_Number
return Logical_Line_Number
is is
SFR : Source_File_Record renames Source_File.Table (S); SFR : Source_File_Record renames Source_File.Table (S);
...@@ -935,6 +689,44 @@ package body Sinput is ...@@ -935,6 +689,44 @@ package body Sinput is
end; end;
end Skip_Line_Terminators; 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 -- -- Source_Offset --
------------------- -------------------
...@@ -943,7 +735,6 @@ package body Sinput is ...@@ -943,7 +735,6 @@ package body Sinput is
Sindex : constant Source_File_Index := Get_Source_File_Index (S); Sindex : constant Source_File_Index := Get_Source_File_Index (S);
Sfirst : constant Source_Ptr := Sfirst : constant Source_Ptr :=
Source_File.Table (Sindex).Source_First; Source_File.Table (Sindex).Source_First;
begin begin
return Nat (S - Sfirst); return Nat (S - Sfirst);
end Source_Offset; end Source_Offset;
...@@ -1368,7 +1159,6 @@ package body Sinput is ...@@ -1368,7 +1159,6 @@ package body Sinput is
else else
return Source_File.Table (S).Source_Last; return Source_File.Table (S).Source_Last;
end if; end if;
end Source_Last; end Source_Last;
function Source_Text (S : SFI) return Source_Buffer_Ptr is function Source_Text (S : SFI) return Source_Buffer_Ptr is
...@@ -1378,7 +1168,6 @@ package body Sinput is ...@@ -1378,7 +1168,6 @@ package body Sinput is
else else
return Source_File.Table (S).Source_Text; return Source_File.Table (S).Source_Text;
end if; end if;
end Source_Text; end Source_Text;
function Template (S : SFI) return SFI is function Template (S : SFI) return SFI is
......
gcc/ada/sinput.ads
...@@ -471,14 +471,6 @@ package Sinput is ...@@ -471,14 +471,6 @@ package Sinput is
-- ASCII.NUL, with Name_Length indicating the length not including the -- ASCII.NUL, with Name_Length indicating the length not including the
-- terminating Nul. -- 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; function Get_Column_Number (P : Source_Ptr) return Column_Number;
-- The ones-origin column number of the specified Source_Ptr value is -- The ones-origin column number of the specified Source_Ptr value is
-- determined and returned. Tab characters if present are assumed to -- determined and returned. Tab characters if present are assumed to
...@@ -571,12 +563,12 @@ package Sinput is ...@@ -571,12 +563,12 @@ package Sinput is
procedure Skip_Line_Terminators procedure Skip_Line_Terminators
(P : in out Source_Ptr; (P : in out Source_Ptr;
Physical : out Boolean); Physical : out Boolean);
-- On entry, P points to a line terminator that has been encountered, which -- On entry, P points to a line terminator that has been encountered,
-- is one of FF,LF,VT,CR or a wide character sequence whose value is in -- which is one of FF,LF,VT,CR or a wide character sequence whose value is
-- category Separator,Line or Separator,Paragraph. P points just past the -- in category Separator,Line or Separator,Paragraph. P points just past
-- character that was scanned. The purpose of this routine is to -- the character that was scanned. The purpose of this routine is to
-- distinguish physical and logical line endings. A physical line ending is -- distinguish physical and logical line endings. A physical line ending
-- one of: -- is one of:
-- --
-- CR on its own (MAC System 7) -- CR on its own (MAC System 7)
-- LF on its own (Unix and unix-like systems) -- LF on its own (Unix and unix-like systems)
...@@ -603,6 +595,15 @@ package Sinput is ...@@ -603,6 +595,15 @@ package Sinput is
-- makes sure that the lines table for the current source file has an -- makes sure that the lines table for the current source file has an
-- appropriate entry for the start of the new physical line. -- 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; function Source_Offset (S : Source_Ptr) return Nat;
-- Returns the zero-origin offset of the given source location from the -- Returns the zero-origin offset of the given source location from the
-- start of its corresponding unit. This is used for creating canonical -- start of its corresponding unit. This is used for creating canonical
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment