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

[multiple changes] 

2009-07-13  Robert Dewar  <dewar@adacore.com>

	* gnat_ugn.texi: The gnatf switch no longer is needed to get full
	details on unsupported constructs.

	* rtsfind.adb: Remove references to All_Errors_Mode, give errors
	unconditionally.

	* s-trafor-default.adb: Correct some warnings

	* s-valwch.adb, a-calend.adb, freeze.adb, prj.ads, s-vmexta.adb,
	sem.adb, sem_ch10.adb, sem_ch6.adb, sem_disp.adb, vxaddr2line.adb:
	Minor reformatting.

	* par-ch4.adb (Conditional_Expression): Capture proper location for
	conditional expression, should point to IF.

	* s-tassta.adb, a-wtdeau.adb, s-tasren.adb, s-arit64.adb, s-imgdec.adb,
	s-direio.adb, s-tpobop.adb, g-socket.adb, s-tposen.adb, s-taskin.adb,
	g-calend.adb, s-regpat.adb, s-scaval.adb, g-catiio.adb: Minor code
	reorganization (use conditional expressions).

2009-07-13  Ed Schonberg  <schonberg@adacore.com>

	* exp_util.adb (Remove_Side_Effects): If the expression is a call to a
	build-in-place function that returns an inherently limited type (not
	just a task type) create proper object declaration so that extra
	build-in-place actuals are properly added to the call.

From-SVN: r149551
This commit is contained in:
Arnaud Charlet 2009-07-13 10:39:28 +02:00
parent 79afa047b2
commit 019578498e
30 changed files with 198 additions and 343 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
gcc/ada/ChangeLog
View File

@ -1,3 +1,32 @@
2009-07-13 Robert Dewar <dewar@adacore.com>
* gnat_ugn.texi: The gnatf switch no longer is needed to get full
details on unsupported constructs.
* rtsfind.adb: Remove references to All_Errors_Mode, give errors
unconditionally.
* s-trafor-default.adb: Correct some warnings
* s-valwch.adb, a-calend.adb, freeze.adb, prj.ads, s-vmexta.adb,
sem.adb, sem_ch10.adb, sem_ch6.adb, sem_disp.adb, vxaddr2line.adb:
Minor reformatting.
* par-ch4.adb (Conditional_Expression): Capture proper location for
conditional expression, should point to IF.
* s-tassta.adb, a-wtdeau.adb, s-tasren.adb, s-arit64.adb, s-imgdec.adb,
s-direio.adb, s-tpobop.adb, g-socket.adb, s-tposen.adb, s-taskin.adb,
g-calend.adb, s-regpat.adb, s-scaval.adb, g-catiio.adb: Minor code
reorganization (use conditional expressions).
2009-07-13 Ed Schonberg <schonberg@adacore.com>
* exp_util.adb (Remove_Side_Effects): If the expression is a call to a
build-in-place function that returns an inherently limited type (not
just a task type) create proper object declaration so that extra
build-in-place actuals are properly added to the call.
2009-07-13 Robert Dewar <dewar@adacore.com> 2009-07-13 Robert Dewar <dewar@adacore.com>
* freeze.adb (Freeze_Entity): Implement Warn_On_Suspicious_Modulus_Value * freeze.adb (Freeze_Entity): Implement Warn_On_Suspicious_Modulus_Value

4
gcc/ada/a-calend.adb
View File

@ -1357,8 +1357,8 @@ package body Ada.Calendar is
Res_N := Res_N + Duration_To_Time_Rep (Day_Secs); Res_N := Res_N + Duration_To_Time_Rep (Day_Secs);
else else
Res_N := Res_N + Res_N :=
Time_Rep (Hour * 3_600 + Minute * 60 + Second) * Nano; Res_N + Time_Rep (Hour * 3_600 + Minute * 60 + Second) * Nano;
if Sub_Sec = 1.0 then if Sub_Sec = 1.0 then
Res_N := Res_N + Time_Rep (1) * Nano; Res_N := Res_N + Time_Rep (1) * Nano;

9
gcc/ada/a-wtdeau.adb
View File

@ -244,11 +244,10 @@ package body Ada.Wide_Text_IO.Decimal_Aux is
Ptr : Natural := 0; Ptr : Natural := 0;
begin begin
if Exp = 0 then Fore :=
Fore := To'Length - 1 - Aft; (if Exp = 0
else then To'Length - 1 - Aft
Fore := To'Length - 2 - Aft - Exp; else To'Length - 2 - Aft - Exp);
end if;
if Fore < 1 then if Fore < 1 then
raise Layout_Error; raise Layout_Error;

12
gcc/ada/exp_util.adb
View File

@ -1350,7 +1350,7 @@ package body Exp_Util is
Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type))); Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type)));
end if; end if;
-- In Ada95, Nothing to be done if the type of the expression is -- In Ada95, nothing to be done if the type of the expression is
-- limited, because in this case the expression cannot be copied, -- limited, because in this case the expression cannot be copied,
-- and its use can only be by reference. -- and its use can only be by reference.
@ -4736,15 +4736,17 @@ package body Exp_Util is
-- Otherwise we generate a reference to the value -- Otherwise we generate a reference to the value
else else
-- Special processing for function calls that return a task. We need -- Special processing for function calls that return a limited type.
-- to build a declaration that will enable build-in-place expansion -- We need to build a declaration that will enable build-in-place
-- of the call. -- expansion of the call. This is not done if the context is already
-- an object declaration, to prevent infinite recursion.
-- This is relevant only in Ada 2005 mode. In Ada 95 programs we have -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have
-- to accommodate functions returning limited objects by reference. -- to accommodate functions returning limited objects by reference.
if Nkind (Exp) = N_Function_Call if Nkind (Exp) = N_Function_Call
and then Is_Task_Type (Etype (Exp)) and then Is_Inherently_Limited_Type (Etype (Exp))
and then Nkind (Parent (Exp)) /= N_Object_Declaration
and then Ada_Version >= Ada_05 and then Ada_Version >= Ada_05
then then
declare declare

2
gcc/ada/freeze.adb
View File

@ -1127,7 +1127,7 @@ package body Freeze is
begin begin
Par := Parent (E); Par := Parent (E);
-- Array may be qualified, so find outer context. -- Array may be qualified, so find outer context
if Nkind (Par) = N_Qualified_Expression then if Nkind (Par) = N_Qualified_Expression then
Par := Parent (Par); Par := Parent (Par);

46
gcc/ada/g-calend.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1999-2008, AdaCore -- -- Copyright (C) 1999-2009, AdaCore --
-- -- -- --
-- 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- --
@ -182,12 +182,7 @@ package body GNAT.Calendar is
begin begin
Split (Date, Year, Month, Day, Day_Secs); Split (Date, Year, Month, Day, Day_Secs);
if Day_Secs = 0.0 then Secs := (if Day_Secs = 0.0 then 0 else Natural (Day_Secs - 0.5));
Secs := 0;
else
Secs := Natural (Day_Secs - 0.5);
end if;
Sub_Second := Second_Duration (Day_Secs - Day_Duration (Secs)); Sub_Second := Second_Duration (Day_Secs - Day_Duration (Secs));
Hour := Hour_Number (Secs / 3_600); Hour := Hour_Number (Secs / 3_600);
Secs := Secs mod 3_600; Secs := Secs mod 3_600;
@ -370,18 +365,9 @@ package body GNAT.Calendar is
begin begin
if Last_Year then if Last_Year then
if Is_Leap (Year - 1) then Shift := (if Is_Leap (Year - 1) then -2 else -1);
Shift := -2;
else
Shift := -1;
end if;
elsif Next_Year then elsif Next_Year then
if Is_Leap (Year) then Shift := (if Is_Leap (Year) then 2 else 1);
Shift := 2;
else
Shift := 1;
end if;
end if; end if;
return Day_Name'Val ((Day_Name'Pos (Jan_1) + Shift) mod 7); return Day_Name'Val ((Day_Name'Pos (Jan_1) + Shift) mod 7);
@ -452,11 +438,11 @@ package body GNAT.Calendar is
-- when special casing the first week of January and the last week of -- when special casing the first week of January and the last week of
-- December. -- December.
if Day = 1 and then Month = 1 then Jan_1 := Day_Of_Week (if Day = 1 and then Month = 1
Jan_1 := Day_Of_Week (Date); then Date
else else (Time_Of (Year, 1, 1, 0.0)));
Jan_1 := Day_Of_Week (Time_Of (Year, 1, 1, 0.0));
end if; -- Special cases for January
if Month = 1 then if Month = 1 then
@ -479,11 +465,7 @@ package body GNAT.Calendar is
or else or else
(Day = 3 and then Jan_1 = Friday) (Day = 3 and then Jan_1 = Friday)
then then
if Last_Year_Has_53_Weeks (Jan_1, Year) then Week := (if Last_Year_Has_53_Weeks (Jan_1, Year) then 53 else 52);
Week := 53;
else
Week := 52;
end if;
-- January 1, 2 and 3 belong to the previous year -- January 1, 2 and 3 belong to the previous year
@ -516,6 +498,8 @@ package body GNAT.Calendar is
return; return;
end if; end if;
-- Month other than 1
-- Special case 3: December 29, 30 and 31. These days may belong to -- Special case 3: December 29, 30 and 31. These days may belong to
-- next year's first week. -- next year's first week.
@ -551,11 +535,7 @@ package body GNAT.Calendar is
-- not belong to the first week of the input year, then the next week -- not belong to the first week of the input year, then the next week
-- is the first week. -- is the first week.
if Jan_1 in Friday .. Sunday then Start_Week := (if Jan_1 in Friday .. Sunday then 1 else 2);
Start_Week := 1;
else
Start_Week := 2;
end if;
-- At this point all special combinations have been accounted for and -- At this point all special combinations have been accounted for and
-- the proper start week has been found. Since January 1 may not fall -- the proper start week has been found. Since January 1 may not fall

14
gcc/ada/g-catiio.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1999-2008, AdaCore -- -- Copyright (C) 1999-2009, AdaCore --
-- -- -- --
-- 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- --
@ -471,15 +471,11 @@ package body GNAT.Calendar.Time_IO is
when 'w' => when 'w' =>
declare declare
DOW : Natural range 0 .. 6; DOW : constant Natural range 0 .. 6 :=
(if Day_Of_Week (Date) = Sunday
then 0
else Day_Name'Pos (Day_Of_Week (Date)));
begin begin
if Day_Of_Week (Date) = Sunday then
DOW := 0;
else
DOW := Day_Name'Pos (Day_Of_Week (Date));
end if;
Result := Result & Image (DOW, Length => 1); Result := Result & Image (DOW, Length => 1);
end; end;

17
gcc/ada/g-socket.adb
View File

@ -1150,11 +1150,7 @@ package body GNAT.Sockets is
-- Start of processing for Image -- Start of processing for Image
begin begin
if Hex then Separator := (if Hex then ':' else '.');
Separator := ':';
else
Separator := '.';
end if;
for J in Val'Range loop for J in Val'Range loop
if Hex then if Hex then
@ -1592,6 +1588,7 @@ package body GNAT.Sockets is
-- Last is set to Stream_Element_Offset'Last. -- Last is set to Stream_Element_Offset'Last.
Last := Ada.Streams.Stream_Element_Offset'Last; Last := Ada.Streams.Stream_Element_Offset'Last;
else else
Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1); Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
end if; end if;
@ -1873,6 +1870,7 @@ package body GNAT.Sockets is
-- Last is set to Stream_Element_Offset'Last. -- Last is set to Stream_Element_Offset'Last.
Last := Ada.Streams.Stream_Element_Offset'Last; Last := Ada.Streams.Stream_Element_Offset'Last;
else else
Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1); Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
end if; end if;
@ -1904,11 +1902,10 @@ package body GNAT.Sockets is
pragma Warnings (Off); pragma Warnings (Off);
-- Following test may be compile time known on some targets -- Following test may be compile time known on some targets
if Vector'Length - Iov_Count > SOSC.IOV_MAX then This_Iov_Count :=
This_Iov_Count := SOSC.IOV_MAX; (if Vector'Length - Iov_Count > SOSC.IOV_MAX
else then SOSC.IOV_MAX
This_Iov_Count := Vector'Length - Iov_Count; else Vector'Length - Iov_Count);
end if;
pragma Warnings (On); pragma Warnings (On);

2
gcc/ada/gnat_ugn.texi
View File

@ -4784,8 +4784,6 @@ some error messages. Some examples are:
@itemize @bullet @itemize @bullet
@item @item
Full details on entities not available in high integrity mode
@item
Details on possibly non-portable unchecked conversion Details on possibly non-portable unchecked conversion
@item @item
List possible interpretations for ambiguous calls List possible interpretations for ambiguous calls

2
gcc/ada/par-ch4.adb
View File

@ -2658,7 +2658,7 @@ package body Ch4 is
function P_Conditional_Expression return Node_Id is function P_Conditional_Expression return Node_Id is
Exprs : constant List_Id := New_List; Exprs : constant List_Id := New_List;
Loc : constant Source_Ptr := Scan_Ptr; Loc : constant Source_Ptr := Token_Ptr;
Expr : Node_Id; Expr : Node_Id;
State : Saved_Scan_State; State : Saved_Scan_State;

2
gcc/ada/prj.ads
View File

@ -1236,7 +1236,7 @@ package Prj is
end record; end record;
function Empty_Project return Project_Data; function Empty_Project return Project_Data;
-- Return the representation of an empty project. -- Return the representation of an empty project
function Is_Extending function Is_Extending
(Extending : Project_Id; (Extending : Project_Id;

37
gcc/ada/rtsfind.adb
View File

@ -158,8 +158,8 @@ package body Rtsfind is
-- "had semantic errors" -- "had semantic errors"
-- --
-- The "not found" case is treated specially in that it is considered -- The "not found" case is treated specially in that it is considered
-- a normal situation in configurable run-time mode (and the message in -- a normal situation in configurable run-time mode, and generates
-- this case is suppressed unless we are operating in All_Errors_Mode). -- a warning, but is otherwise ignored.
procedure Load_RTU procedure Load_RTU
(U_Id : RTU_Id; (U_Id : RTU_Id;
@ -537,30 +537,25 @@ package body Rtsfind is
-- Output file name and reason string -- Output file name and reason string
if S /= "not found" M (1 .. 6) := "\file ";
or else not Configurable_Run_Time_Mode P := 6;
or else All_Errors_Mode
then
M (1 .. 6) := "\file ";
P := 6;
Get_Name_String Get_Name_String
(Get_File_Name (RT_Unit_Table (U_Id).Uname, Subunit => False)); (Get_File_Name (RT_Unit_Table (U_Id).Uname, Subunit => False));
M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len); M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len);
P := P + Name_Len; P := P + Name_Len;
M (P + 1) := ' '; M (P + 1) := ' ';
P := P + 1; P := P + 1;
M (P + 1 .. P + S'Length) := S; M (P + 1 .. P + S'Length) := S;
P := P + S'Length; P := P + S'Length;
RTE_Error_Msg (M (1 .. P)); RTE_Error_Msg (M (1 .. P));
-- Output entity name -- Output entity name
Output_Entity_Name (Id, "not available"); Output_Entity_Name (Id, "not available");
end if;
-- In configurable run time mode, we raise RE_Not_Available, and the -- In configurable run time mode, we raise RE_Not_Available, and the
-- caller is expected to deal gracefully with this. In the case of a -- caller is expected to deal gracefully with this. In the case of a
@ -869,7 +864,7 @@ package body Rtsfind is
RE_Image : constant String := RE_Id'Image (Id); RE_Image : constant String := RE_Id'Image (Id);
begin begin
if Id = RE_Null or else not All_Errors_Mode then if Id = RE_Null then
return; return;
end if; end if;

46
gcc/ada/s-arit64.adb
View File

@ -211,11 +211,7 @@ package body System.Arith_64 is
end if; end if;
else else
if Zhi /= 0 then T2 := (if Zhi /= 0 then Ylo * Zhi else 0);
T2 := Ylo * Zhi;
else
T2 := 0;
end if;
end if; end if;
T1 := Ylo * Zlo; T1 := Ylo * Zlo;
@ -254,23 +250,13 @@ package body System.Arith_64 is
if X >= 0 then if X >= 0 then
R := To_Int (Ru); R := To_Int (Ru);
Q := (if Den_Pos then To_Int (Qu) else -To_Int (Qu));
if Den_Pos then
Q := To_Int (Qu);
else
Q := -To_Int (Qu);
end if;
-- Case of dividend (X) sign negative -- Case of dividend (X) sign negative
else else
R := -To_Int (Ru); R := -To_Int (Ru);
Q := (if Den_Pos then -To_Int (Qu) else To_Int (Qu));
if Den_Pos then
Q := -To_Int (Qu);
else
Q := To_Int (Qu);
end if;
end if; end if;
end Double_Divide; end Double_Divide;
@ -548,11 +534,9 @@ package body System.Arith_64 is
-- which ensured the first bit of the divisor is set, this gives -- which ensured the first bit of the divisor is set, this gives
-- an estimate of the quotient that is at most two too high. -- an estimate of the quotient that is at most two too high.
if D (J + 1) = Zhi then Qd (J + 1) := (if D (J + 1) = Zhi
Qd (J + 1) := 2 ** 32 - 1; then 2 ** 32 - 1
else else Lo ((D (J + 1) & D (J + 2)) / Zhi));
Qd (J + 1) := Lo ((D (J + 1) & D (J + 2)) / Zhi);
end if;
-- Compute amount to subtract -- Compute amount to subtract
@ -598,27 +582,15 @@ package body System.Arith_64 is
-- Case of dividend (X * Y) sign positive -- Case of dividend (X * Y) sign positive
if (X >= 0 and then Y >= 0) if (X >= 0 and then Y >= 0) or else (X < 0 and then Y < 0) then
or else (X < 0 and then Y < 0)
then
R := To_Pos_Int (Ru); R := To_Pos_Int (Ru);
Q := (if Z > 0 then To_Pos_Int (Qu) else To_Neg_Int (Qu));
if Z > 0 then
Q := To_Pos_Int (Qu);
else
Q := To_Neg_Int (Qu);
end if;
-- Case of dividend (X * Y) sign negative -- Case of dividend (X * Y) sign negative
else else
R := To_Neg_Int (Ru); R := To_Neg_Int (Ru);
Q := (if Z > 0 then To_Neg_Int (Qu) else To_Pos_Int (Qu));
if Z > 0 then
Q := To_Neg_Int (Qu);
else
Q := To_Pos_Int (Qu);
end if;
end if; end if;
end Scaled_Divide; end Scaled_Divide;

12
gcc/ada/s-direio.adb
View File

@ -223,11 +223,7 @@ package body System.Direct_IO is
-- last operation as other, to force the file position to be reset -- last operation as other, to force the file position to be reset
-- on the next read. -- on the next read.
if File.Bytes = Size then File.Last_Op := (if File.Bytes = Size then Op_Read else Op_Other);
File.Last_Op := Op_Read;
else
File.Last_Op := Op_Other;
end if;
end Read; end Read;
-- The following is the required overriding for Stream.Read, which is -- The following is the required overriding for Stream.Read, which is
@ -376,11 +372,7 @@ package body System.Direct_IO is
-- last operation as other, to force the file position to be reset -- last operation as other, to force the file position to be reset
-- on the next write. -- on the next write.
if File.Bytes = Size then File.Last_Op := (if File.Bytes = Size then Op_Write else Op_Other);
File.Last_Op := Op_Write;
else
File.Last_Op := Op_Other;
end if;
end Write; end Write;
-- The following is the required overriding for Stream.Write, which is -- The following is the required overriding for Stream.Write, which is

7
gcc/ada/s-imgdec.adb
View File

@ -273,12 +273,7 @@ package body System.Img_Dec is
-- exception is for the value zero, which by convention has an -- exception is for the value zero, which by convention has an
-- exponent of +0. -- exponent of +0.
if Zero then Expon := (if Zero then 0 else Digits_Before_Point - 1);
Expon := 0;
else
Expon := Digits_Before_Point - 1;
end if;
Set ('E'); Set ('E');
ND := 0; ND := 0;

171
gcc/ada/s-regpat.adb
View File

@ -7,7 +7,7 @@
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1986 by University of Toronto. -- -- Copyright (C) 1986 by University of Toronto. --
-- Copyright (C) 1999-2008, AdaCore -- -- Copyright (C) 1999-2009, AdaCore --
-- -- -- --
-- 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- --
@ -988,29 +988,23 @@ package body System.Regpat is
case (C) is case (C) is
when '^' => when '^' =>
if (Flags and Multiple_Lines) /= 0 then IP :=
IP := Emit_Node (MBOL); Emit_Node
elsif (Flags and Single_Line) /= 0 then (if (Flags and Multiple_Lines) /= 0 then MBOL
IP := Emit_Node (SBOL); elsif (Flags and Single_Line) /= 0 then SBOL
else else BOL);
IP := Emit_Node (BOL);
end if;
when '$' => when '$' =>
if (Flags and Multiple_Lines) /= 0 then IP :=
IP := Emit_Node (MEOL); Emit_Node
elsif (Flags and Single_Line) /= 0 then (if (Flags and Multiple_Lines) /= 0 then MEOL
IP := Emit_Node (SEOL); elsif (Flags and Single_Line) /= 0 then SEOL
else else EOL);
IP := Emit_Node (EOL);
end if;
when '.' => when '.' =>
if (Flags and Single_Line) /= 0 then IP :=
IP := Emit_Node (SANY); Emit_Node
else (if (Flags and Single_Line) /= 0 then SANY else ANY);
IP := Emit_Node (ANY);
end if;
Expr_Flags.Has_Width := True; Expr_Flags.Has_Width := True;
Expr_Flags.Simple := True; Expr_Flags.Simple := True;
@ -1146,15 +1140,9 @@ package body System.Regpat is
begin begin
Flags := Worst_Expression; -- Tentatively Flags := Worst_Expression; -- Tentatively
IP := (if First then Emit_Ptr else Emit_Node (BRANCH));
if First then
IP := Emit_Ptr;
else
IP := Emit_Node (BRANCH);
end if;
Chain := 0; Chain := 0;
while Parse_Pos <= Parse_End while Parse_Pos <= Parse_End
and then E (Parse_Pos) /= ')' and then E (Parse_Pos) /= ')'
and then E (Parse_Pos) /= ASCII.LF and then E (Parse_Pos) /= ASCII.LF
@ -1566,11 +1554,9 @@ package body System.Regpat is
begin begin
Parse_Pos := Parse_Pos - 1; -- Look at current character Parse_Pos := Parse_Pos - 1; -- Look at current character
if (Flags and Case_Insensitive) /= 0 then IP :=
IP := Emit_Node (EXACTF); Emit_Node
else (if (Flags and Case_Insensitive) /= 0 then EXACTF else EXACT);
IP := Emit_Node (EXACT);
end if;
Length_Ptr := Emit_Ptr; Length_Ptr := Emit_Ptr;
Emit_Ptr := String_Operand (IP); Emit_Ptr := String_Operand (IP);
@ -1707,11 +1693,10 @@ package body System.Regpat is
Op := Expression (Parse_Pos); Op := Expression (Parse_Pos);
if Op /= '+' then Expr_Flags :=
Expr_Flags := (SP_Start => True, others => False); (if Op /= '+'
else then (SP_Start => True, others => False)
Expr_Flags := (Has_Width => True, others => False); else (Has_Width => True, others => False));
end if;
-- Detect non greedy operators in the easy cases -- Detect non greedy operators in the easy cases
@ -1840,36 +1825,23 @@ package body System.Regpat is
if if
E (Parse_Pos .. Parse_Pos + Alnum'Length - 1) = Alnum E (Parse_Pos .. Parse_Pos + Alnum'Length - 1) = Alnum
then then
if Invert then Class :=
Class := ANYOF_NALNUMC; (if Invert then ANYOF_NALNUMC else ANYOF_ALNUMC);
else
Class := ANYOF_ALNUMC;
end if;
Parse_Pos := Parse_Pos + Alnum'Length; Parse_Pos := Parse_Pos + Alnum'Length;
elsif elsif
E (Parse_Pos .. Parse_Pos + Alpha'Length - 1) = Alpha E (Parse_Pos .. Parse_Pos + Alpha'Length - 1) = Alpha
then then
if Invert then Class :=
Class := ANYOF_NALPHA; (if Invert then ANYOF_NALPHA else ANYOF_ALPHA);
else
Class := ANYOF_ALPHA;
end if;
Parse_Pos := Parse_Pos + Alpha'Length; Parse_Pos := Parse_Pos + Alpha'Length;
elsif E (Parse_Pos .. Parse_Pos + Ascii_C'Length - 1) = elsif E (Parse_Pos .. Parse_Pos + Ascii_C'Length - 1) =
Ascii_C Ascii_C
then then
if Invert then Class :=
Class := ANYOF_NASCII; (if Invert then ANYOF_NASCII else ANYOF_ASCII);
else
Class := ANYOF_ASCII;
end if;
Parse_Pos := Parse_Pos + Ascii_C'Length; Parse_Pos := Parse_Pos + Ascii_C'Length;
else else
Fail ("Invalid character class: " & E); Fail ("Invalid character class: " & E);
end if; end if;
@ -1883,14 +1855,8 @@ package body System.Regpat is
and then and then
E (Parse_Pos .. Parse_Pos + Cntrl'Length - 1) = Cntrl E (Parse_Pos .. Parse_Pos + Cntrl'Length - 1) = Cntrl
then then
if Invert then Class := (if Invert then ANYOF_NCNTRL else ANYOF_CNTRL);
Class := ANYOF_NCNTRL;
else
Class := ANYOF_CNTRL;
end if;
Parse_Pos := Parse_Pos + Cntrl'Length; Parse_Pos := Parse_Pos + Cntrl'Length;
else else
Fail ("Invalid character class: " & E); Fail ("Invalid character class: " & E);
end if; end if;
@ -1900,12 +1866,7 @@ package body System.Regpat is
and then and then
E (Parse_Pos .. Parse_Pos + Digit'Length - 1) = Digit E (Parse_Pos .. Parse_Pos + Digit'Length - 1) = Digit
then then
if Invert then Class := (if Invert then ANYOF_NDIGIT else ANYOF_DIGIT);
Class := ANYOF_NDIGIT;
else
Class := ANYOF_DIGIT;
end if;
Parse_Pos := Parse_Pos + Digit'Length; Parse_Pos := Parse_Pos + Digit'Length;
end if; end if;
@ -1914,14 +1875,8 @@ package body System.Regpat is
and then and then
E (Parse_Pos .. Parse_Pos + Graph'Length - 1) = Graph E (Parse_Pos .. Parse_Pos + Graph'Length - 1) = Graph
then then
if Invert then Class := (if Invert then ANYOF_NGRAPH else ANYOF_GRAPH);
Class := ANYOF_NGRAPH;
else
Class := ANYOF_GRAPH;
end if;
Parse_Pos := Parse_Pos + Graph'Length; Parse_Pos := Parse_Pos + Graph'Length;
else else
Fail ("Invalid character class: " & E); Fail ("Invalid character class: " & E);
end if; end if;
@ -1931,14 +1886,8 @@ package body System.Regpat is
and then and then
E (Parse_Pos .. Parse_Pos + Lower'Length - 1) = Lower E (Parse_Pos .. Parse_Pos + Lower'Length - 1) = Lower
then then
if Invert then Class := (if Invert then ANYOF_NLOWER else ANYOF_LOWER);
Class := ANYOF_NLOWER;
else
Class := ANYOF_LOWER;
end if;
Parse_Pos := Parse_Pos + Lower'Length; Parse_Pos := Parse_Pos + Lower'Length;
else else
Fail ("Invalid character class: " & E); Fail ("Invalid character class: " & E);
end if; end if;
@ -1951,23 +1900,15 @@ package body System.Regpat is
if if
E (Parse_Pos .. Parse_Pos + Print'Length - 1) = Print E (Parse_Pos .. Parse_Pos + Print'Length - 1) = Print
then then
if Invert then Class :=
Class := ANYOF_NPRINT; (if Invert then ANYOF_NPRINT else ANYOF_PRINT);
else
Class := ANYOF_PRINT;
end if;
Parse_Pos := Parse_Pos + Print'Length; Parse_Pos := Parse_Pos + Print'Length;
elsif elsif
E (Parse_Pos .. Parse_Pos + Punct'Length - 1) = Punct E (Parse_Pos .. Parse_Pos + Punct'Length - 1) = Punct
then then
if Invert then Class :=
Class := ANYOF_NPUNCT; (if Invert then ANYOF_NPUNCT else ANYOF_PUNCT);
else
Class := ANYOF_PUNCT;
end if;
Parse_Pos := Parse_Pos + Punct'Length; Parse_Pos := Parse_Pos + Punct'Length;
else else
@ -1983,14 +1924,8 @@ package body System.Regpat is
and then and then
E (Parse_Pos .. Parse_Pos + Space'Length - 1) = Space E (Parse_Pos .. Parse_Pos + Space'Length - 1) = Space
then then
if Invert then Class := (if Invert then ANYOF_NSPACE else ANYOF_SPACE);
Class := ANYOF_NSPACE;
else
Class := ANYOF_SPACE;
end if;
Parse_Pos := Parse_Pos + Space'Length; Parse_Pos := Parse_Pos + Space'Length;
else else
Fail ("Invalid character class: " & E); Fail ("Invalid character class: " & E);
end if; end if;
@ -2000,14 +1935,8 @@ package body System.Regpat is
and then and then
E (Parse_Pos .. Parse_Pos + Upper'Length - 1) = Upper E (Parse_Pos .. Parse_Pos + Upper'Length - 1) = Upper
then then
if Invert then Class := (if Invert then ANYOF_NUPPER else ANYOF_UPPER);
Class := ANYOF_NUPPER;
else
Class := ANYOF_UPPER;
end if;
Parse_Pos := Parse_Pos + Upper'Length; Parse_Pos := Parse_Pos + Upper'Length;
else else
Fail ("Invalid character class: " & E); Fail ("Invalid character class: " & E);
end if; end if;
@ -2017,14 +1946,8 @@ package body System.Regpat is
and then and then
E (Parse_Pos .. Parse_Pos + Word'Length - 1) = Word E (Parse_Pos .. Parse_Pos + Word'Length - 1) = Word
then then
if Invert then Class := (if Invert then ANYOF_NALNUM else ANYOF_ALNUM);
Class := ANYOF_NALNUM;
else
Class := ANYOF_ALNUM;
end if;
Parse_Pos := Parse_Pos + Word'Length; Parse_Pos := Parse_Pos + Word'Length;
else else
Fail ("Invalid character class: " & E); Fail ("Invalid character class: " & E);
end if; end if;
@ -2034,12 +1957,7 @@ package body System.Regpat is
and then and then
E (Parse_Pos .. Parse_Pos + Xdigit'Length - 1) = Xdigit E (Parse_Pos .. Parse_Pos + Xdigit'Length - 1) = Xdigit
then then
if Invert then Class := (if Invert then ANYOF_NXDIGIT else ANYOF_XDIGIT);
Class := ANYOF_NXDIGIT;
else
Class := ANYOF_XDIGIT;
end if;
Parse_Pos := Parse_Pos + Xdigit'Length; Parse_Pos := Parse_Pos + Xdigit'Length;
else else
@ -2633,11 +2551,10 @@ package body System.Regpat is
N := Is_Alnum (Data (Input_Pos - 1)); N := Is_Alnum (Data (Input_Pos - 1));
end if; end if;
if Input_Pos > Last_In_Data then Ln :=
Ln := False; (if Input_Pos > Last_In_Data
else then False
Ln := Is_Alnum (Data (Input_Pos)); else Is_Alnum (Data (Input_Pos)));
end if;
if Op = BOUND then if Op = BOUND then
if N = Ln then if N = Ln then

19
gcc/ada/s-scaval.adb
View File

@ -270,17 +270,14 @@ package body System.Scalar_Values is
else else
-- Convert the two hex digits (we know they are valid here) -- Convert the two hex digits (we know they are valid here)
if C1 in '0' .. '9' then B := 16 * (Character'Pos (C1)
B := Character'Pos (C1) - Character'Pos ('0'); - (if C1 in '0' .. '9'
else then Character'Pos ('0')
B := Character'Pos (C1) - (Character'Pos ('A') - 10); else Character'Pos ('A') - 10))
end if; + (Character'Pos (C2)
- (if C2 in '0' .. '9'
if C2 in '0' .. '9' then then Character'Pos ('0')
B := B * 16 + Character'Pos (C2) - Character'Pos ('0'); else Character'Pos ('A') - 10));
else
B := B * 16 + Character'Pos (C2) - (Character'Pos ('A') - 10);
end if;
-- Initialize data values from the hex value -- Initialize data values from the hex value

9
gcc/ada/s-taskin.adb
View File

@ -187,11 +187,10 @@ package body System.Tasking is
-- Initialize Environment Task -- Initialize Environment Task
if Main_Priority = Unspecified_Priority then Base_Priority :=
Base_Priority := Default_Priority; (if Main_Priority = Unspecified_Priority
else then Default_Priority
Base_Priority := Priority (Main_Priority); else Priority (Main_Priority));
end if;
T := STPO.New_ATCB (0); T := STPO.New_ATCB (0);
Initialize_ATCB Initialize_ATCB

18
gcc/ada/s-tasren.adb
View File

@ -405,11 +405,10 @@ package body System.Tasking.Rendezvous is
-- If this is a call made inside of an abort deferred region, -- If this is a call made inside of an abort deferred region,
-- the call should be never abortable. -- the call should be never abortable.
if Self_Id.Deferral_Level > 1 then Entry_Call.State :=
Entry_Call.State := Never_Abortable; (if Self_Id.Deferral_Level > 1
else then Never_Abortable
Entry_Call.State := Now_Abortable; else Now_Abortable);
end if;
Entry_Call.E := Entry_Index (E); Entry_Call.E := Entry_Index (E);
Entry_Call.Prio := Get_Priority (Self_Id); Entry_Call.Prio := Get_Priority (Self_Id);
@ -1706,11 +1705,10 @@ package body System.Tasking.Rendezvous is
-- If this is a call made inside of an abort deferred region, -- If this is a call made inside of an abort deferred region,
-- the call should be never abortable. -- the call should be never abortable.
if Self_Id.Deferral_Level > 1 then Entry_Call.State :=
Entry_Call.State := Never_Abortable; (if Self_Id.Deferral_Level > 1
else then Never_Abortable
Entry_Call.State := Now_Abortable; else Now_Abortable);
end if;
Entry_Call.E := Entry_Index (E); Entry_Call.E := Entry_Index (E);
Entry_Call.Prio := Get_Priority (Self_Id); Entry_Call.Prio := Get_Priority (Self_Id);

28
gcc/ada/s-tassta.adb
View File

@ -282,11 +282,10 @@ package body System.Tasking.Stages is
Write_Lock (P); Write_Lock (P);
Write_Lock (C); Write_Lock (C);
if C.Common.Base_Priority < Get_Priority (Self_ID) then Activate_Prio :=
Activate_Prio := Get_Priority (Self_ID); (if C.Common.Base_Priority < Get_Priority (Self_ID)
else then Get_Priority (Self_ID)
Activate_Prio := C.Common.Base_Priority; else C.Common.Base_Priority);
end if;
System.Task_Primitives.Operations.Create_Task System.Task_Primitives.Operations.Create_Task
(C, Task_Wrapper'Address, (C, Task_Wrapper'Address,
@ -517,11 +516,10 @@ package body System.Tasking.Stages is
pragma Debug (Debug.Trace (Self_ID, "Create_Task", 'C')); pragma Debug (Debug.Trace (Self_ID, "Create_Task", 'C'));
if Priority = Unspecified_Priority then Base_Priority :=
Base_Priority := Self_ID.Common.Base_Priority; (if Priority = Unspecified_Priority
else then Self_ID.Common.Base_Priority
Base_Priority := System.Any_Priority (Priority); else System.Any_Priority (Priority));
end if;
-- Find parent P of new Task, via master level number -- Find parent P of new Task, via master level number
@ -589,6 +587,7 @@ package body System.Tasking.Stages is
-- confused when waiting for these tasks to terminate. -- confused when waiting for these tasks to terminate.
T.Master_of_Task := Library_Task_Level; T.Master_of_Task := Library_Task_Level;
else else
T.Master_of_Task := Master; T.Master_of_Task := Master;
end if; end if;
@ -1075,11 +1074,10 @@ package body System.Tasking.Stages is
-- Assume a size of the stack taken at this stage -- Assume a size of the stack taken at this stage
if Size < Small_Stack_Limit then Overflow_Guard :=
Overflow_Guard := Small_Overflow_Guard; (if Size < Small_Stack_Limit
else then Small_Overflow_Guard
Overflow_Guard := Big_Overflow_Guard; else Big_Overflow_Guard);
end if;
if not Parameters.Sec_Stack_Dynamic then if not Parameters.Sec_Stack_Dynamic then
Self_ID.Common.Compiler_Data.Sec_Stack_Addr := Self_ID.Common.Compiler_Data.Sec_Stack_Addr :=

20
gcc/ada/s-tpobop.adb
View File

@ -582,11 +582,9 @@ package body System.Tasking.Protected_Objects.Operations is
Entry_Call.Mode := Mode; Entry_Call.Mode := Mode;
Entry_Call.Cancellation_Attempted := False; Entry_Call.Cancellation_Attempted := False;
if Self_ID.Deferral_Level > 1 then Entry_Call.State :=
Entry_Call.State := Never_Abortable; (if Self_ID.Deferral_Level > 1
else then Never_Abortable else Now_Abortable);
Entry_Call.State := Now_Abortable;
end if;
Entry_Call.E := Entry_Index (E); Entry_Call.E := Entry_Index (E);
Entry_Call.Prio := STPO.Get_Priority (Self_ID); Entry_Call.Prio := STPO.Get_Priority (Self_ID);
@ -972,17 +970,15 @@ package body System.Tasking.Protected_Objects.Operations is
pragma Debug pragma Debug
(Debug.Trace (Self_Id, "TPEC: exited to ATC level: " & (Debug.Trace (Self_Id, "TPEC: exited to ATC level: " &
ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
Entry_Call := Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access;
Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access;
Entry_Call.Next := null; Entry_Call.Next := null;
Entry_Call.Mode := Timed_Call; Entry_Call.Mode := Timed_Call;
Entry_Call.Cancellation_Attempted := False; Entry_Call.Cancellation_Attempted := False;
if Self_Id.Deferral_Level > 1 then Entry_Call.State :=
Entry_Call.State := Never_Abortable; (if Self_Id.Deferral_Level > 1
else then Never_Abortable
Entry_Call.State := Now_Abortable; else Now_Abortable);
end if;
Entry_Call.E := Entry_Index (E); Entry_Call.E := Entry_Index (E);
Entry_Call.Prio := STPO.Get_Priority (Self_Id); Entry_Call.Prio := STPO.Get_Priority (Self_Id);

7
gcc/ada/s-tposen.adb
View File

@ -231,12 +231,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
STPO.Timed_Sleep STPO.Timed_Sleep
(Self_Id, Wakeup_Time, Mode, Entry_Caller_Sleep, Timedout, Yielded); (Self_Id, Wakeup_Time, Mode, Entry_Caller_Sleep, Timedout, Yielded);
if Timedout then Entry_Call.State := (if Timedout then Cancelled else Done);
Entry_Call.State := Cancelled;
else
Entry_Call.State := Done;
end if;
Self_Id.Common.State := Runnable; Self_Id.Common.State := Runnable;
end Wait_For_Completion_With_Timeout; end Wait_For_Completion_With_Timeout;

11
gcc/ada/s-trafor-default.adb
View File

@ -40,8 +40,8 @@ package body System.Traces.Format is
------------------ ------------------
function Format_Trace (Source : String) return String_Trace is function Format_Trace (Source : String) return String_Trace is
Length : Integer := Source'Length; Length : constant Integer := Source'Length;
Result : String_Trace := (others => ' '); Result : String_Trace := (others => ' ');
begin begin
-- If run-time tracing active, then fill the string -- If run-time tracing active, then fill the string
@ -52,7 +52,8 @@ package body System.Traces.Format is
Result (Length + 1 .. Max_Size) := (others => ' '); Result (Length + 1 .. Max_Size) := (others => ' ');
Result (Length + 1) := ASCII.NUL; Result (Length + 1) := ASCII.NUL;
else else
Result (1 .. Max_Size - 1) := Source (1 .. Max_Size - 1); Result (1 .. Max_Size - 1) :=
Source (Source'First .. Source'First - 1 + Max_Size - 1);
Result (Max_Size) := ASCII.NUL; Result (Max_Size) := ASCII.NUL;
end if; end if;
end if; end if;
@ -68,8 +69,8 @@ package body System.Traces.Format is
(Source : String_Trace; (Source : String_Trace;
Annex : String) return String_Trace Annex : String) return String_Trace
is is
Result : String_Trace := (others => ' '); Result : String_Trace := (others => ' ');
Annex_Length : Integer := Annex'Length; Annex_Length : constant Integer := Annex'Length;
Source_Length : Integer; Source_Length : Integer;
begin begin

1
gcc/ada/s-valwch.adb
View File

@ -119,7 +119,6 @@ package body System.Val_WChar is
if S (F + 1) = '[' then if S (F + 1) = '[' then
W := Wide_Wide_Character'Val (UTF_32 ('[', WCEM_Brackets)); W := Wide_Wide_Character'Val (UTF_32 ('[', WCEM_Brackets));
else else
W := Wide_Wide_Character'Val (UTF_32 (S (F + 1), EM)); W := Wide_Wide_Character'Val (UTF_32 (S (F + 1), EM));
end if; end if;

2
gcc/ada/s-vmexta.adb
View File

@ -29,7 +29,7 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This is an Alpha/VMS package. -- This is an Alpha/VMS package
with System.HTable; with System.HTable;
pragma Elaborate_All (System.HTable); pragma Elaborate_All (System.HTable);

2
gcc/ada/sem.adb
View File

@ -1788,7 +1788,7 @@ package body Sem is
end; end;
end loop; end loop;
-- Now traverse compilation units in order. -- Now traverse compilation units in order
Cur := First_Elmt (Comp_Unit_List); Cur := First_Elmt (Comp_Unit_List);
while Present (Cur) loop while Present (Cur) loop

2
gcc/ada/sem_ch10.adb
View File

@ -5721,7 +5721,7 @@ package body Sem_Ch10 is
end if; end if;
end if; end if;
-- Preserve structure of homonym chain. -- Preserve structure of homonym chain
Set_Homonym (E, Homonym (Lim_Typ)); Set_Homonym (E, Homonym (Lim_Typ));
end if; end if;

2
gcc/ada/sem_ch6.adb
View File

@ -2637,7 +2637,7 @@ package body Sem_Ch6 is
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Make_Null_Statement (Loc)))); Statements => New_List (Make_Null_Statement (Loc))));
-- Create new entities for body and formals. -- Create new entities for body and formals
Set_Defining_Unit_Name (Specification (Null_Body), Set_Defining_Unit_Name (Specification (Null_Body),
Make_Defining_Identifier (Loc, Chars (Defining_Entity (N)))); Make_Defining_Identifier (Loc, Chars (Defining_Entity (N))));

4
gcc/ada/sem_disp.adb
View File

@ -758,7 +758,7 @@ package body Sem_Disp is
E := First_Entity (Subp); E := First_Entity (Subp);
while Present (E) loop while Present (E) loop
-- For an access parameter, check designated type. -- For an access parameter, check designated type
if Ekind (Etype (E)) = E_Anonymous_Access_Type then if Ekind (Etype (E)) = E_Anonymous_Access_Type then
Typ := Designated_Type (Etype (E)); Typ := Designated_Type (Etype (E));
@ -1346,7 +1346,7 @@ package body Sem_Disp is
Set_Scope (Subp, Current_Scope); Set_Scope (Subp, Current_Scope);
Tagged_Type := Find_Dispatching_Type (Subp); Tagged_Type := Find_Dispatching_Type (Subp);
-- Add Old_Subp to primitive operations if not already present. -- Add Old_Subp to primitive operations if not already present
if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then
Append_Unique_Elmt (Old_Subp, Primitive_Operations (Tagged_Type)); Append_Unique_Elmt (Old_Subp, Primitive_Operations (Tagged_Type));

4
gcc/ada/vxaddr2line.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2002-2008, AdaCore -- -- Copyright (C) 2002-2009, AdaCore --
-- -- -- --
-- 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,7 +75,7 @@ with GNAT.Regpat; use GNAT.Regpat;
procedure VxAddr2Line is procedure VxAddr2Line is
package Unsigned_32_IO is new Modular_IO (Unsigned_32); package Unsigned_32_IO is new Modular_IO (Unsigned_32);
-- Instantiate Modular_IO to have Put. -- Instantiate Modular_IO to have Put
Ref_Symbol : constant String := "adainit"; Ref_Symbol : constant String := "adainit";
-- This is the name of the reference symbol which runtime address shall -- This is the name of the reference symbol which runtime address shall