mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-24 12:31:25 +08:00
Code Issues Packages Projects Releases Wiki Activity

sem_aggr.adb, [...]: Update all eligible case statements to reflect the new style for case alternatives.

Browse Source 
2017-01-13  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_aggr.adb, par_sco.adb, s-osprim-mingw.adb, exp_ch5.adb,
	exp_prag.adb, sem_ch3.adb, xr_tabls.adb, lib-xref-spark_specific.adb,
	layout.adb, sem_dist.adb, exp_spark.adb, exp_ch7.adb, gnatcmd.adb,
	exp_util.adb, prj-proc.adb, sem_aux.adb, comperr.adb, g-memdum.adb,
	exp_attr.adb, s-intman-solaris.adb, exp_ch9.adb, make.adb, live.adb,
	g-sercom-linux.adb, sem_dim.adb, mlib-prj.adb, s-intman-posix.adb,
	sem_ch9.adb, sem_ch10.adb, prep.adb, einfo.adb, scng.adb, checks.adb,
	prj-strt.adb, sem_prag.adb, eval_fat.adb, sem_ch12.adb, sem.adb,
	a-numaux-x86.adb, a-stwifi.adb, i-cobol.adb, prj.adb,
	get_spark_xrefs.adb, s-tasini.adb, rtsfind.adb, freeze.adb,
	g-arrspl.adb, par-ch4.adb, sem_util.adb, sem_res.adb, expander.adb,
	sem_attr.adb, exp_dbug.adb, prj-pp.adb, a-stzfix.adb, s-interr.adb,
	s-wchcnv.adb, switch-m.adb, gnat1drv.adb, sinput-l.adb, stylesw.adb,
	contracts.adb, s-intman-android.adb, g-expect.adb, exp_ch4.adb,
	g-comlin.adb, errout.adb, sinput.adb, s-exctra.adb, repinfo.adb,
	g-spipat.adb, g-debpoo.adb, exp_ch6.adb, sem_ch4.adb, exp_ch13.adb,
	a-wtedit.adb, validsw.adb, pprint.adb, widechar.adb, makeutl.adb,
	ali.adb, set_targ.adb, sem_mech.adb, sem_ch6.adb, gnatdll.adb,
	get_scos.adb, g-pehage.adb, s-tratas-default.adb, gnatbind.adb,
	prj-dect.adb, g-socthi-mingw.adb, par-prag.adb, prj-nmsc.adb,
	exp_disp.adb, par-ch12.adb, binde.adb, sem_ch8.adb,
	s-tfsetr-default.adb, s-regexp.adb, gprep.adb, s-tpobop.adb,
	a-teioed.adb, sem_warn.adb, sem_eval.adb, g-awk.adb, s-io.adb,
	a-ztedit.adb, xoscons.adb, exp_intr.adb, sem_cat.adb, sprint.adb,
	g-socket.adb, exp_dist.adb, sem_ch13.adb, s-tfsetr-vxworks.adb,
	par-ch3.adb, treepr.adb, g-forstr.adb, g-catiio.adb, par-ch5.adb,
	uname.adb, osint.adb, exp_ch3.adb, prj-env.adb, a-strfix.adb,
	a-stzsup.adb, prj-tree.adb, s-fileio.adb: Update all eligible case
	statements to reflect the new style for case alternatives. Various
	code clean up and reformatting.

From-SVN: r244406
This commit is contained in:
Hristian Kirtchev 2017-01-13 10:19:19 +00:00 committed by Arnaud Charlet
parent d4bf622fbf
commit d8f43ee6d0
129 changed files with 5134 additions and 4555 deletions

33
gcc/ada/ChangeLog

@ -1,3 +1,36 @@
2017-01-13 Hristian Kirtchev <kirtchev@adacore.com>
* sem_aggr.adb, par_sco.adb, s-osprim-mingw.adb, exp_ch5.adb,
exp_prag.adb, sem_ch3.adb, xr_tabls.adb, lib-xref-spark_specific.adb,
layout.adb, sem_dist.adb, exp_spark.adb, exp_ch7.adb, gnatcmd.adb,
exp_util.adb, prj-proc.adb, sem_aux.adb, comperr.adb, g-memdum.adb,
exp_attr.adb, s-intman-solaris.adb, exp_ch9.adb, make.adb, live.adb,
g-sercom-linux.adb, sem_dim.adb, mlib-prj.adb, s-intman-posix.adb,
sem_ch9.adb, sem_ch10.adb, prep.adb, einfo.adb, scng.adb, checks.adb,
prj-strt.adb, sem_prag.adb, eval_fat.adb, sem_ch12.adb, sem.adb,
a-numaux-x86.adb, a-stwifi.adb, i-cobol.adb, prj.adb,
get_spark_xrefs.adb, s-tasini.adb, rtsfind.adb, freeze.adb,
g-arrspl.adb, par-ch4.adb, sem_util.adb, sem_res.adb, expander.adb,
sem_attr.adb, exp_dbug.adb, prj-pp.adb, a-stzfix.adb, s-interr.adb,
s-wchcnv.adb, switch-m.adb, gnat1drv.adb, sinput-l.adb, stylesw.adb,
contracts.adb, s-intman-android.adb, g-expect.adb, exp_ch4.adb,
g-comlin.adb, errout.adb, sinput.adb, s-exctra.adb, repinfo.adb,
g-spipat.adb, g-debpoo.adb, exp_ch6.adb, sem_ch4.adb, exp_ch13.adb,
a-wtedit.adb, validsw.adb, pprint.adb, widechar.adb, makeutl.adb,
ali.adb, set_targ.adb, sem_mech.adb, sem_ch6.adb, gnatdll.adb,
get_scos.adb, g-pehage.adb, s-tratas-default.adb, gnatbind.adb,
prj-dect.adb, g-socthi-mingw.adb, par-prag.adb, prj-nmsc.adb,
exp_disp.adb, par-ch12.adb, binde.adb, sem_ch8.adb,
s-tfsetr-default.adb, s-regexp.adb, gprep.adb, s-tpobop.adb,
a-teioed.adb, sem_warn.adb, sem_eval.adb, g-awk.adb, s-io.adb,
a-ztedit.adb, xoscons.adb, exp_intr.adb, sem_cat.adb, sprint.adb,
g-socket.adb, exp_dist.adb, sem_ch13.adb, s-tfsetr-vxworks.adb,
par-ch3.adb, treepr.adb, g-forstr.adb, g-catiio.adb, par-ch5.adb,
uname.adb, osint.adb, exp_ch3.adb, prj-env.adb, a-strfix.adb,
a-stzsup.adb, prj-tree.adb, s-fileio.adb: Update all eligible case
statements to reflect the new style for case alternatives. Various
code clean up and reformatting.
2017-01-13 Gary Dismukes <dismukes@adacore.com>
* exp_util.adb: Minor reformatting.

8
gcc/ada/a-numaux-x86.adb

@ -7,7 +7,7 @@
-- B o d y --
-- (Machine Version for x86) --
-- --
-- Copyright (C) 1998-2014, Free Software Foundation, Inc. --
-- Copyright (C) 1998-2016, 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- --
@ -263,14 +263,17 @@ package body Ada.Numerics.Aux is
Asm (Template => "fcos",
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", Reduced_X));
when 1 =>
Asm (Template => "fsin",
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", -Reduced_X));
when 2 =>
Asm (Template => "fcos ; fchs",
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", Reduced_X));
when 3 =>
Asm (Template => "fsin",
Outputs => Double'Asm_Output ("=t", Result),
@ -448,14 +451,17 @@ package body Ada.Numerics.Aux is
Asm (Template => "fsin",
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", Reduced_X));
when 1 =>
Asm (Template => "fcos",
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", Reduced_X));
when 2 =>
Asm (Template => "fsin",
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", -Reduced_X));
when 3 =>
Asm (Template => "fcos ; fchs",
Outputs => Double'Asm_Output ("=t", Result),

4
gcc/ada/a-strfix.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
@ -349,7 +349,6 @@ package body Ada.Strings.Fixed is
Target := Source;
elsif Slength > Tlength then
case Drop is
when Left =>
Target := Source (Slast - Tlength + 1 .. Slast);
@ -377,7 +376,6 @@ package body Ada.Strings.Fixed is
when Center =>
raise Length_Error;
end case;
end case;
-- Source'Length < Target'Length

4
gcc/ada/a-stwifi.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
@ -327,7 +327,6 @@ package body Ada.Strings.Wide_Fixed is
Target := Source;
elsif Slength > Tlength then
case Drop is
when Left =>
Target := Source (Slast - Tlength + 1 .. Slast);
@ -355,7 +354,6 @@ package body Ada.Strings.Wide_Fixed is
when Center =>
raise Length_Error;
end case;
end case;
-- Source'Length < Target'Length

3
gcc/ada/a-stzfix.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
@ -329,7 +329,6 @@ package body Ada.Strings.Wide_Wide_Fixed is
Target := Source;
elsif Slength > Tlength then
case Drop is
when Left =>
Target := Source (Slast - Tlength + 1 .. Slast);

3
gcc/ada/a-stzsup.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2003-2012, Free Software Foundation, Inc. --
-- Copyright (C) 2003-2016, 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- --
@ -529,7 +529,6 @@ package body Ada.Strings.Wide_Wide_Superbounded is
raise Ada.Strings.Length_Error;
end case;
end if;
end Super_Append;
-- Case of Wide_Wide_String and Super_String

76
gcc/ada/a-teioed.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
@ -69,7 +69,6 @@ package body Ada.Text_IO.Editing is
loop
case Picture (Picture_Index) is
when '(' =>
Int_IO.Get
(Picture (Picture_Index + 1 .. Picture'Last), Count, Last);
@ -107,7 +106,6 @@ package body Ada.Text_IO.Editing is
Result (Result_Index) := Picture (Picture_Index);
Picture_Index := Picture_Index + 1;
Result_Index := Result_Index + 1;
end case;
exit when Picture_Index > Picture'Last;
@ -219,7 +217,6 @@ package body Ada.Text_IO.Editing is
exit when Answer (Last) = '9';
case Answer (Last) is
when '_' =>
Answer (Last) := Separator_Character;
@ -228,7 +225,6 @@ package body Ada.Text_IO.Editing is
when others =>
null;
end case;
exit when Last = Answer'Last;
@ -248,7 +244,6 @@ package body Ada.Text_IO.Editing is
end if;
case Answer (J) is
when '_' =>
Answer (J) := Separator_Character;
@ -260,7 +255,6 @@ package body Ada.Text_IO.Editing is
when others =>
null;
end case;
end loop;
@ -442,7 +436,6 @@ package body Ada.Text_IO.Editing is
for J in reverse Pic.Start_Float .. Position loop
case Answer (J) is
when '*' =>
Answer (J) := Fill_Character;
@ -472,9 +465,7 @@ package body Ada.Text_IO.Editing is
end if;
when '_' =>
case Pic.Floater is
when '*' =>
Answer (J) := Fill_Character;
@ -492,12 +483,10 @@ package body Ada.Text_IO.Editing is
when others =>
null;
end case;
when others =>
null;
end case;
end loop;
@ -528,13 +517,11 @@ package body Ada.Text_IO.Editing is
when others =>
raise Picture_Error;
end case;
else -- positive
case Answer (Sign_Position) is
when '-' =>
Answer (Sign_Position) := ' ';
@ -547,7 +534,6 @@ package body Ada.Text_IO.Editing is
when others =>
raise Picture_Error;
end case;
end if;
end if;
@ -580,7 +566,6 @@ package body Ada.Text_IO.Editing is
elsif Answer (J) = '_' then
Answer (J) := Separator_Character;
end if;
Last := J + 1;
@ -668,7 +653,6 @@ package body Ada.Text_IO.Editing is
Currency_Pos := Currency_Pos + 1;
case Pic.Floater is
when '*' =>
Answer (J) := Fill_Character;
@ -685,12 +669,10 @@ package body Ada.Text_IO.Editing is
when others =>
null;
end case;
when others =>
exit;
end case;
end loop;
@ -855,7 +837,6 @@ package body Ada.Text_IO.Editing is
begin
for J in Str'Range loop
case Str (J) is
when ' ' =>
null; -- ignore
@ -1094,7 +1075,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@ -1181,7 +1161,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
when '-' =>
Pic.Max_Trailing_Digits :=
Pic.Max_Trailing_Digits + 1;
@ -1197,7 +1176,6 @@ package body Ada.Text_IO.Editing is
when others =>
return;
end case;
end loop;
@ -1264,7 +1242,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
when '+' =>
Pic.Max_Trailing_Digits :=
Pic.Max_Trailing_Digits + 1;
@ -1280,7 +1257,6 @@ package body Ada.Text_IO.Editing is
when others =>
return;
end case;
end loop;
@ -1292,7 +1268,6 @@ package body Ada.Text_IO.Editing is
when others =>
return;
end case;
end loop;
end Floating_Plus;
@ -1308,14 +1283,15 @@ package body Ada.Text_IO.Editing is
end if;
case Pic.Picture.Expanded (Index) is
when '_' | '0' | '/' => return True;
when '_' | '0' | '/' =>
return True;
when 'B' | 'b' =>
Pic.Picture.Expanded (Index) := 'b'; -- canonical
return True;
when others => return False;
when others =>
return False;
end case;
end Is_Insert;
@ -1362,7 +1338,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@ -1438,7 +1413,6 @@ package body Ada.Text_IO.Editing is
when others =>
return;
end case;
end loop;
end Leading_Dollar;
@ -1499,7 +1473,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Inserts := True;
@ -1605,7 +1578,6 @@ package body Ada.Text_IO.Editing is
Debug_Start ("Number");
loop
case Look is
when '_' | '0' | '/' =>
Skip;
@ -1628,7 +1600,6 @@ package body Ada.Text_IO.Editing is
when others =>
return;
end case;
if At_End then
@ -1650,7 +1621,6 @@ package body Ada.Text_IO.Editing is
while not At_End loop
case Look is
when '_' | '0' | '/' =>
Skip;
@ -1725,8 +1695,8 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' => Skip;
when '_' | '0' | '/' =>
Skip;
when 'B' | 'b' =>
Pic.Picture.Expanded (Index) := 'b';
@ -1837,7 +1807,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Skip;
@ -1856,7 +1825,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Skip;
@ -1872,14 +1840,12 @@ package body Ada.Text_IO.Editing is
when others =>
return;
end case;
end loop;
when others =>
Number_Fraction;
return;
end case;
end loop;
end Number_Fraction_Or_Pound;
@ -1898,7 +1864,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Skip;
@ -1918,7 +1883,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Skip;
@ -1941,7 +1905,6 @@ package body Ada.Text_IO.Editing is
when others =>
Number_Fraction;
return;
end case;
end loop;
end Number_Fraction_Or_Star_Fill;
@ -1960,7 +1923,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Skip;
@ -1981,7 +1943,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Skip;
@ -2022,7 +1983,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
when '+' | '-' =>
Pic.Sign_Position := Index;
Skip;
@ -2071,7 +2031,6 @@ package body Ada.Text_IO.Editing is
when others =>
return;
end case;
end Optional_RHS_Sign;
@ -2094,7 +2053,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Skip;
@ -2125,7 +2083,6 @@ package body Ada.Text_IO.Editing is
when others =>
return;
end case;
end loop;
end Picture;
@ -2153,7 +2110,6 @@ package body Ada.Text_IO.Editing is
loop
case Look is
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@ -2197,7 +2153,6 @@ package body Ada.Text_IO.Editing is
when others =>
raise Picture_Error;
end case;
end loop;
end Picture_Bracket;
@ -2225,7 +2180,6 @@ package body Ada.Text_IO.Editing is
loop
case Look is
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@ -2283,7 +2237,6 @@ package body Ada.Text_IO.Editing is
when others =>
return;
end case;
end loop;
end Picture_Minus;
@ -2310,7 +2263,6 @@ package body Ada.Text_IO.Editing is
loop
case Look is
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@ -2377,7 +2329,6 @@ package body Ada.Text_IO.Editing is
when others =>
return;
end case;
end loop;
end Picture_Plus;
@ -2395,7 +2346,6 @@ package body Ada.Text_IO.Editing is
end loop;
case Look is
when '$' | '#' =>
Picture;
Optional_RHS_Sign;
@ -2427,7 +2377,6 @@ package body Ada.Text_IO.Editing is
when others =>
raise Picture_Error;
end case;
-- Blank when zero either if the PIC does not contain a '9' or if
@ -2444,7 +2393,6 @@ package body Ada.Text_IO.Editing is
if not At_End then
Set_State (Reject);
end if;
end Picture_String;
---------------
@ -2509,7 +2457,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@ -2546,7 +2493,8 @@ package body Ada.Text_IO.Editing is
Set_State (Okay);
return;
when others => raise Picture_Error;
when others =>
raise Picture_Error;
end case;
end loop;
end Star_Suppression;
@ -2601,13 +2549,15 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' => Skip;
when '_' | '0' | '/' =>
Skip;
when 'B' | 'b' =>
Pic.Picture.Expanded (Index) := 'b';
Skip;
when others => return;
when others =>
return;
end case;
end loop;
end Trailing_Currency;

79
gcc/ada/a-wtedit.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
@ -210,7 +210,6 @@ package body Ada.Wide_Text_IO.Editing is
loop
case Picture (Picture_Index) is
when '(' =>
-- We now need to scan out the count after a left paren. In
@ -275,7 +274,6 @@ package body Ada.Wide_Text_IO.Editing is
Result (Result_Index) := Picture (Picture_Index);
Picture_Index := Picture_Index + 1;
Result_Index := Result_Index + 1;
end case;
exit when Picture_Index > Picture'Last;
@ -390,7 +388,6 @@ package body Ada.Wide_Text_IO.Editing is
exit when Answer (Last) = '9';
case Answer (Last) is
when '_' =>
Answer (Last) := Separator_Character;
@ -399,7 +396,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
null;
end case;
exit when Last = Answer'Last;
@ -419,7 +415,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Answer (J) is
when '_' =>
Answer (J) := Separator_Character;
@ -431,7 +426,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
null;
end case;
end loop;
@ -613,7 +607,6 @@ package body Ada.Wide_Text_IO.Editing is
for J in reverse Pic.Start_Float .. Position loop
case Answer (J) is
when '*' =>
Answer (J) := Fill_Character;
@ -635,9 +628,7 @@ package body Ada.Wide_Text_IO.Editing is
end if;
when '_' =>
case Pic.Floater is
when '*' =>
Answer (J) := Fill_Character;
@ -655,12 +646,10 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
null;
end case;
when others =>
null;
end case;
end loop;
@ -691,13 +680,11 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
raise Picture_Error;
end case;
else -- positive
case Answer (Sign_Position) is
when '-' =>
Answer (Sign_Position) := ' ';
@ -710,7 +697,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
raise Picture_Error;
end case;
end if;
end if;
@ -724,7 +710,6 @@ package body Ada.Wide_Text_IO.Editing is
Last := Pic.Radix_Position + 1;
for J in Last .. Answer'Last loop
if Answer (J) = '9' or else Answer (J) = Pic.Floater then
Answer (J) := To_Wide (Rounded (Position));
@ -821,7 +806,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
when '_' =>
case Pic.Floater is
when '*' =>
@ -840,12 +824,10 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
null;
end case;
when others =>
exit;
end case;
end loop;
@ -1013,7 +995,6 @@ package body Ada.Wide_Text_IO.Editing is
begin
for J in Str'Range loop
case Str (J) is
when ' ' =>
null; -- ignore
@ -1188,7 +1169,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@ -1219,7 +1199,7 @@ package body Ada.Wide_Text_IO.Editing is
return;
when others =>
return;
return;
end case;
end loop;
end Floating_Bracket;
@ -1273,7 +1253,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
when '-' =>
Pic.Max_Trailing_Digits :=
Pic.Max_Trailing_Digits + 1;
@ -1289,7 +1268,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
return;
end case;
end loop;
@ -1354,7 +1332,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
when '+' =>
Pic.Max_Trailing_Digits :=
Pic.Max_Trailing_Digits + 1;
@ -1370,7 +1347,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
return;
end case;
end loop;
@ -1382,7 +1358,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
return;
end case;
end loop;
end Floating_Plus;
@ -1398,14 +1373,15 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Pic.Picture.Expanded (Index) is
when '_' | '0' | '/' => return True;
when '_' | '0' | '/' =>
return True;
when 'B' | 'b' =>
Pic.Picture.Expanded (Index) := 'b'; -- canonical
return True;
when others => return False;
when others =>
return False;
end case;
end Is_Insert;
@ -1441,7 +1417,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@ -1513,7 +1488,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
return;
end case;
end loop;
end Leading_Dollar;
@ -1565,7 +1539,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Inserts := True;
@ -1666,7 +1639,6 @@ package body Ada.Wide_Text_IO.Editing is
procedure Number is
begin
loop
case Look is
when '_' | '0' | '/' =>
Skip;
@ -1689,7 +1661,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
return;
end case;
if At_End then
@ -1709,7 +1680,6 @@ package body Ada.Wide_Text_IO.Editing is
begin
while not At_End loop
case Look is
when '_' | '0' | '/' =>
Skip;
@ -1780,8 +1750,8 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' => Skip;
when '_' | '0' | '/' =>
Skip;
when 'B' | 'b' =>
Pic.Picture.Expanded (Index) := 'b';
@ -1890,7 +1860,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Skip;
@ -1909,7 +1878,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Skip;
@ -1925,14 +1893,12 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
return;
end case;
end loop;
when others =>
Number_Fraction;
return;
end case;
end loop;
end Number_Fraction_Or_Pound;
@ -1949,7 +1915,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Skip;
@ -1969,7 +1934,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Skip;
@ -1992,7 +1956,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
Number_Fraction;
return;
end case;
end loop;
end Number_Fraction_Or_Star_Fill;
@ -2009,7 +1972,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Skip;
@ -2030,7 +1992,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Skip;
@ -2069,7 +2030,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
when '+' | '-' =>
Pic.Sign_Position := Index;
Skip;
@ -2118,7 +2078,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
return;
end case;
end Optional_RHS_Sign;
@ -2139,7 +2098,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Skip;
@ -2170,7 +2128,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
return;
end case;
end loop;
end Picture;
@ -2197,7 +2154,6 @@ package body Ada.Wide_Text_IO.Editing is
loop
case Look is
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@ -2241,7 +2197,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
raise Picture_Error;
end case;
end loop;
end Picture_Bracket;
@ -2267,7 +2222,6 @@ package body Ada.Wide_Text_IO.Editing is
loop
case Look is
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@ -2325,7 +2279,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
return;
end case;
end loop;
end Picture_Minus;
@ -2351,7 +2304,6 @@ package body Ada.Wide_Text_IO.Editing is
loop
case Look is
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@ -2413,7 +2365,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
return;
end case;
end loop;
end Picture_Plus;
@ -2429,7 +2380,6 @@ package body Ada.Wide_Text_IO.Editing is
end loop;
case Look is
when '$' | '#' =>
Picture;
Optional_RHS_Sign;
@ -2461,7 +2411,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
raise Picture_Error;
end case;
-- Blank when zero either if the PIC does not contain a '9' or if
@ -2478,7 +2427,6 @@ package body Ada.Wide_Text_IO.Editing is
if not At_End then
Set_State (Reject);
end if;
end Picture_String;
---------------
@ -2522,7 +2470,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@ -2553,7 +2500,8 @@ package body Ada.Wide_Text_IO.Editing is
Set_State (Okay);
return;
when others => raise Picture_Error;
when others =>
raise Picture_Error;
end case;
end loop;
end Star_Suppression;
@ -2604,13 +2552,15 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' => Skip;
when '_' | '0' | '/' =>
Skip;
when 'B' | 'b' =>
Pic.Picture.Expanded (Index) := 'b';
Skip;
when others => return;
when others =>
return;
end case;
end loop;
end Trailing_Currency;
@ -2693,7 +2643,6 @@ package body Ada.Wide_Text_IO.Editing is
-- To deal with special cases like null strings
raise Picture_Error;
end Precalculate;
----------------

83
gcc/ada/a-ztedit.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
@ -211,7 +211,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
loop
case Picture (Picture_Index) is
when '(' =>
-- We now need to scan out the count after a left paren. In
@ -276,7 +275,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
Result (Result_Index) := Picture (Picture_Index);
Picture_Index := Picture_Index + 1;
Result_Index := Result_Index + 1;
end case;
exit when Picture_Index > Picture'Last;
@ -391,7 +389,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
exit when Answer (Last) = '9';
case Answer (Last) is
when '_' =>
Answer (Last) := Separator_Character;
@ -400,7 +397,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
null;
end case;
exit when Last = Answer'Last;
@ -420,7 +416,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Answer (J) is
when '_' =>
Answer (J) := Separator_Character;
@ -432,7 +427,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
null;
end case;
end loop;
@ -614,7 +608,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
for J in reverse Pic.Start_Float .. Position loop
case Answer (J) is
when '*' =>
Answer (J) := Fill_Character;
@ -636,9 +629,7 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
when '_' =>
case Pic.Floater is
when '*' =>
Answer (J) := Fill_Character;
@ -656,12 +647,10 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
null;
end case;
when others =>
null;
end case;
end loop;
@ -692,13 +681,11 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
raise Picture_Error;
end case;
else -- positive
case Answer (Sign_Position) is
when '-' =>
Answer (Sign_Position) := ' ';
@ -711,7 +698,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
raise Picture_Error;
end case;
end if;
end if;
@ -719,13 +705,11 @@ package body Ada.Wide_Wide_Text_IO.Editing is
-- Fill in trailing digits
if Pic.Max_Trailing_Digits > 0 then
if Attrs.Has_Fraction then
Position := Attrs.Start_Of_Fraction;
Last := Pic.Radix_Position + 1;
for J in Last .. Answer'Last loop
if Answer (J) = '9' or else Answer (J) = Pic.Floater then
Answer (J) := To_Wide (Rounded (Position));
@ -745,7 +729,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
elsif Answer (J) = '_' then
Answer (J) := Separator_Character;
end if;
Last := J + 1;
@ -773,7 +756,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
elsif Answer (J) = 'b' then
Answer (J) := ' ';
end if;
end loop;
@ -822,9 +804,7 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
when '_' =>
case Pic.Floater is
when '*' =>
Answer (J) := Fill_Character;
@ -841,12 +821,10 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
null;
end case;
when others =>
exit;
end case;
end loop;
@ -931,7 +909,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
-- 9) No radix, no currency expansion
if Pic.Radix_Position /= Invalid_Position then
if Answer (Pic.Radix_Position) = '.' then
Answer (Pic.Radix_Position) := Radix_Point;
@ -1014,7 +991,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
begin
for J in Str'Range loop
case Str (J) is
when ' ' =>
null; -- ignore
@ -1189,7 +1165,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@ -1220,7 +1195,7 @@ package body Ada.Wide_Wide_Text_IO.Editing is
return;
when others =>
return;
return;
end case;
end loop;
end Floating_Bracket;
@ -1274,7 +1249,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
when '-' =>
Pic.Max_Trailing_Digits :=
Pic.Max_Trailing_Digits + 1;
@ -1290,7 +1264,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
return;
end case;
end loop;
@ -1355,7 +1328,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
when '+' =>
Pic.Max_Trailing_Digits :=
Pic.Max_Trailing_Digits + 1;
@ -1371,7 +1343,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
return;
end case;
end loop;
@ -1383,7 +1354,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
return;
end case;
end loop;
end Floating_Plus;
@ -1399,14 +1369,15 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Pic.Picture.Expanded (Index) is
when '_' | '0' | '/' => return True;
when '_' | '0' | '/' =>
return True;
when 'B' | 'b' =>
Pic.Picture.Expanded (Index) := 'b'; -- canonical
return True;
when others => return False;
when others =>
return False;
end case;
end Is_Insert;
@ -1442,7 +1413,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@ -1514,7 +1484,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
return;
end case;
end loop;
end Leading_Dollar;
@ -1534,7 +1503,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
-- floating unless there is only one '#'.
procedure Leading_Pound is
Inserts : Boolean := False;
-- Set to True if a '_', '0', '/', 'B', or 'b' is encountered
@ -1565,7 +1533,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Inserts := True;
@ -1666,7 +1633,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
procedure Number is
begin
loop
case Look is
when '_' | '0' | '/' =>
Skip;
@ -1709,7 +1675,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
begin
while not At_End loop
case Look is
when '_' | '0' | '/' =>
Skip;
@ -1780,8 +1745,8 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' => Skip;
when '_' | '0' | '/' =>
Skip;
when 'B' | 'b' =>
Pic.Picture.Expanded (Index) := 'b';
@ -1890,7 +1855,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Skip;
@ -1909,7 +1873,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Skip;
@ -1925,14 +1888,12 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
return;
end case;
end loop;
when others =>
Number_Fraction;
return;
end case;
end loop;
end Number_Fraction_Or_Pound;
@ -1949,7 +1910,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Skip;
@ -1969,7 +1929,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Skip;
@ -1992,7 +1951,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
Number_Fraction;
return;
end case;
end loop;
end Number_Fraction_Or_Star_Fill;
@ -2009,7 +1967,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Skip;
@ -2030,7 +1987,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Skip;
@ -2069,7 +2025,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
when '+' | '-' =>
Pic.Sign_Position := Index;
Skip;
@ -2118,7 +2073,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
return;
end case;
end Optional_RHS_Sign;
@ -2139,7 +2093,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Skip;
@ -2170,7 +2123,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
return;
end case;
end loop;
end Picture;
@ -2197,7 +2149,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
loop
case Look is
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@ -2241,7 +2192,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
raise Picture_Error;
end case;
end loop;
end Picture_Bracket;
@ -2267,7 +2217,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
loop
case Look is
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@ -2325,7 +2274,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
return;
end case;
end loop;
end Picture_Minus;
@ -2351,7 +2299,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
loop
case Look is
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@ -2413,7 +2360,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
return;
end case;
end loop;
end Picture_Plus;
@ -2429,7 +2375,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end loop;
case Look is
when '$' | '#' =>
Picture;
Optional_RHS_Sign;
@ -2461,7 +2406,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
raise Picture_Error;
end case;
-- Blank when zero either if the PIC does not contain a '9' or if
@ -2478,7 +2422,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
if not At_End then
Set_State (Reject);
end if;
end Picture_String;
---------------
@ -2522,7 +2465,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@ -2553,7 +2495,8 @@ package body Ada.Wide_Wide_Text_IO.Editing is
Set_State (Okay);
return;
when others => raise Picture_Error;
when others =>
raise Picture_Error;
end case;
end loop;
end Star_Suppression;
@ -2604,13 +2547,15 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
when '_' | '0' | '/' => Skip;
when '_' | '0' | '/' =>
Skip;
when 'B' | 'b' =>
Pic.Picture.Expanded (Index) := 'b';
Skip;
when others => return;
when others =>
return;
end case;
end loop;
end Trailing_Currency;

22
gcc/ada/ali.adb

@ -718,7 +718,7 @@ package body ALI is
begin
loop
case Nextc is
when '[' =>
when '[' =>
Nested_Brackets := Nested_Brackets + 1;
when ']' =>
Nested_Brackets := Nested_Brackets - 1;
@ -1464,19 +1464,19 @@ package body ALI is
C := Getc;
case C is
when 'v' =>
ALIs.Table (Id).Restrictions.Violated (R) := True;
Cumulative_Restrictions.Violated (R) := True;
when 'v' =>
ALIs.Table (Id).Restrictions.Violated (R) := True;
Cumulative_Restrictions.Violated (R) := True;
when 'r' =>
ALIs.Table (Id).Restrictions.Set (R) := True;
Cumulative_Restrictions.Set (R) := True;
when 'r' =>
ALIs.Table (Id).Restrictions.Set (R) := True;
Cumulative_Restrictions.Set (R) := True;
when 'n' =>
null;
when 'n' =>
null;
when others =>
raise Bad_R_Line;
when others =>
raise Bad_R_Line;
end case;
end loop;

2
gcc/ada/binde.adb

@ -694,7 +694,6 @@ package body Binde is
----------------------------------
procedure Diagnose_Elaboration_Problem is
function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean;
-- Recursive routine used to find a path from node Ufrom to node Uto.
-- If a path exists, returns True and outputs an appropriate set of
@ -710,7 +709,6 @@ package body Binde is
---------------
function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean is
function Find_Link (U : Unit_Id; PL : Nat) return Boolean;
-- This is the inner recursive routine, it determines if a path
-- exists from U to Uto, and if so returns True and outputs the

60
gcc/ada/checks.adb

@ -4041,26 +4041,30 @@ package body Checks is
if Present (Expr) and then Known_Null (Expr) then
case K is
when N_Component_Declaration |
N_Discriminant_Specification =>
when N_Component_Declaration
| N_Discriminant_Specification
=>
Apply_Compile_Time_Constraint_Error
(N => Expr,
Msg => "(Ada 2005) null not allowed "
& "in null-excluding components??",
Msg =>
"(Ada 2005) null not allowed in null-excluding "
& "components??",
Reason => CE_Null_Not_Allowed);
when N_Object_Declaration =>
Apply_Compile_Time_Constraint_Error
(N => Expr,
Msg => "(Ada 2005) null not allowed "
& "in null-excluding objects??",
Msg =>
"(Ada 2005) null not allowed in null-excluding "
& "objects??",
Reason => CE_Null_Not_Allowed);
when N_Parameter_Specification =>
Apply_Compile_Time_Constraint_Error
(N => Expr,
Msg => "(Ada 2005) null not allowed "
& "in null-excluding formals??",
Msg =>
"(Ada 2005) null not allowed in null-excluding "
& "formals??",
Reason => CE_Null_Not_Allowed);
when others =>
@ -4499,9 +4503,7 @@ package body Checks is
when N_Op_Rem =>
if OK_Operands then
if Lo_Right = Hi_Right
and then Lo_Right /= 0
then
if Lo_Right = Hi_Right and then Lo_Right /= 0 then
declare
Dval : constant Uint := (abs Lo_Right) - 1;
@ -4536,7 +4538,9 @@ package body Checks is
-- For Pos/Val attributes, we can refine the range using the
-- possible range of values of the attribute expression.
when Name_Pos | Name_Val =>
when Name_Pos
| Name_Val
=>
Determine_Range
(First (Expressions (N)), OK1, Lor, Hir, Assume_Valid);
@ -7246,12 +7250,22 @@ package body Checks is
function Is_Signed_Integer_Arithmetic_Op (N : Node_Id) return Boolean is
begin
case Nkind (N) is
when N_Op_Abs | N_Op_Add | N_Op_Divide | N_Op_Expon |
N_Op_Minus | N_Op_Mod | N_Op_Multiply | N_Op_Plus |
N_Op_Rem | N_Op_Subtract =>
when N_Op_Abs
| N_Op_Add
| N_Op_Divide
| N_Op_Expon
| N_Op_Minus
| N_Op_Mod
| N_Op_Multiply
| N_Op_Plus
| N_Op_Rem
| N_Op_Subtract
=>
return Is_Signed_Integer_Type (Etype (N));
when N_If_Expression | N_Case_Expression =>
when N_Case_Expression
| N_If_Expression
=>
return Is_Signed_Integer_Type (Etype (N));
when others =>
@ -8468,28 +8482,28 @@ package body Checks is
begin
case Nkind (N) is
when N_Op_Abs =>
when N_Op_Abs =>
Fent := RTE (RE_Big_Abs);
when N_Op_Add =>
when N_Op_Add =>
Fent := RTE (RE_Big_Add);
when N_Op_Divide =>
when N_Op_Divide =>
Fent := RTE (RE_Big_Div);
when N_Op_Expon =>
when N_Op_Expon =>
Fent := RTE (RE_Big_Exp);
when N_Op_Minus =>
when N_Op_Minus =>
Fent := RTE (RE_Big_Neg);
when N_Op_Mod =>
when N_Op_Mod =>
Fent := RTE (RE_Big_Mod);
when N_Op_Multiply =>
Fent := RTE (RE_Big_Mul);
when N_Op_Rem =>
when N_Op_Rem =>
Fent := RTE (RE_Big_Rem);
when N_Op_Subtract =>

7
gcc/ada/comperr.adb

@ -467,9 +467,10 @@ package body Comperr is
Main := Unit (Cunit (Main_Unit));
case Nkind (Main) is
when N_Package_Declaration |
N_Subprogram_Body |
N_Subprogram_Declaration =>
when N_Package_Declaration
| N_Subprogram_Body
| N_Subprogram_Declaration
=>
Unit_Name := Defining_Unit_Name (Specification (Main));
when N_Package_Body =>

1
gcc/ada/contracts.adb

@ -2940,7 +2940,6 @@ package body Contracts is
end if;
case Nkind (Spec) is
when N_Function_Specification =>
return
Make_Function_Specification (Loc,

1119
gcc/ada/einfo.adb

File diff suppressed because it is too large Load Diff

7
gcc/ada/errout.adb

@ -2814,7 +2814,9 @@ package body Errout is
Set_Msg_Node (Defining_Identifier (Node));
return;
when N_Selected_Component | N_Expanded_Name =>
when N_Expanded_Name
| N_Selected_Component
=>
Set_Msg_Node (Prefix (Node));
Set_Msg_Char ('.');
Set_Msg_Node (Selector_Name (Node));
@ -3426,10 +3428,13 @@ package body Errout is
case Warning_Msg_Char is
when '?' =>
return "??";
when 'a' .. 'z' | 'A' .. 'Z' | '*' | '$' =>
return '?' & Warning_Msg_Char & '?';
when ' ' =>
return "?";
when others =>
raise Program_Error;
end case;

4
gcc/ada/eval_fat.adb

@ -373,7 +373,7 @@ package body Eval_Fat is
Fraction := Fraction + 1;
end if;
when Round =>
when Round =>
-- Do not round to even as is done with IEEE arithmetic, but
-- instead round away from zero when the result is exactly
@ -390,7 +390,7 @@ package body Eval_Fat is
Fraction := Fraction + 1;
end if;
when Floor =>
when Floor =>
if N > Uint_0 and then UR_Is_Negative (X) then
Fraction := Fraction + 1;
end if;

1116
gcc/ada/exp_attr.adb

File diff suppressed because it is too large Load Diff

23
gcc/ada/exp_ch13.adb

@ -113,7 +113,7 @@ package body Exp_Ch13 is
and then Present (Expression (Decl))
and then Nkind (Expression (Decl)) /= N_Null
and then
not Comes_From_Source (Original_Node (Expression (Decl)))
not Comes_From_Source (Original_Node (Expression (Decl)))
then
if Present (Base_Init_Proc (Typ))
and then
@ -122,8 +122,8 @@ package body Exp_Ch13 is
null;
elsif Init_Or_Norm_Scalars
and then
(Is_Scalar_Type (Typ) or else Is_String_Type (Typ))
and then (Is_Scalar_Type (Typ)
or else Is_String_Type (Typ))
then
null;
@ -160,8 +160,7 @@ package body Exp_Ch13 is
-- integer literal (this simplifies things in Gigi).
if Nkind (Exp) /= N_Integer_Literal then
Rewrite
(Exp, Make_Integer_Literal (Loc, Expr_Value (Exp)));
Rewrite (Exp, Make_Integer_Literal (Loc, Expr_Value (Exp)));
end if;
-- A complex case arises if the alignment clause applies to an
@ -175,9 +174,10 @@ package body Exp_Ch13 is
and then not Is_Entity_Name (Renamed_Object (Ent))
then
declare
Loc : constant Source_Ptr := Sloc (N);
Decl : constant Node_Id := Parent (Ent);
Temp : constant Entity_Id := Make_Temporary (Loc, 'T');
Decl : constant Node_Id := Parent (Ent);
Loc : constant Source_Ptr := Sloc (N);
Temp : constant Entity_Id := Make_Temporary (Loc, 'T');
New_Decl : Node_Id;
begin
@ -226,7 +226,7 @@ package body Exp_Ch13 is
begin
Assign :=
Make_Assignment_Statement (Loc,
Name =>
Name =>
New_Occurrence_Of (Storage_Size_Variable (Ent), Loc),
Expression =>
Convert_To (RTE (RE_Size_Type), Expression (N)));
@ -266,9 +266,9 @@ package body Exp_Ch13 is
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => V,
Object_Definition =>
Object_Definition =>
New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
Expression =>
Expression =>
Convert_To (RTE (RE_Storage_Offset), Expression (N))));
Set_Storage_Size_Variable (Ent, Entity_Id (V));
@ -279,7 +279,6 @@ package body Exp_Ch13 is
when others =>
null;
end case;
end Expand_N_Attribute_Definition_Clause;

3
gcc/ada/exp_ch3.adb

@ -3305,7 +3305,6 @@ package body Exp_Ch3 is
-- Remaining processing depends on type
case Ekind (Subtype_Mark_Id) is
when Array_Kind =>
Constrain_Array (S, Check_List);
@ -3327,7 +3326,7 @@ package body Exp_Ch3 is
Needs_Simple_Initialization (T)
and then not Is_RTE (T, RE_Tag)
-- Ada 2005 (AI-251): Check also the tag of abstract interfaces
-- Ada 2005 (AI-251): Check also the tag of abstract interfaces
and then not Is_RTE (T, RE_Interface_Tag);
end Component_Needs_Simple_Initialization;

159
gcc/ada/exp_ch4.adb

@ -2140,47 +2140,47 @@ package body Exp_Ch4 is
if Llo /= No_Uint and then Rlo /= No_Uint then
case N_Op_Compare (Nkind (N)) is
when N_Op_Eq =>
if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
Set_True;
elsif Llo > Rhi or else Lhi < Rlo then
Set_False;
end if;
when N_Op_Eq =>
if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
Set_True;
elsif Llo > Rhi or else Lhi < Rlo then
Set_False;
end if;
when N_Op_Ge =>
if Llo >= Rhi then
Set_True;
elsif Lhi < Rlo then
Set_False;
end if;
when N_Op_Ge =>
if Llo >= Rhi then
Set_True;
elsif Lhi < Rlo then
Set_False;
end if;
when N_Op_Gt =>
if Llo > Rhi then
Set_True;
elsif Lhi <= Rlo then
Set_False;
end if;
when N_Op_Gt =>
if Llo > Rhi then
Set_True;
elsif Lhi <= Rlo then
Set_False;
end if;
when N_Op_Le =>
if Llo > Rhi then
Set_False;
elsif Lhi <= Rlo then
Set_True;
end if;
when N_Op_Le =>
if Llo > Rhi then
Set_False;
elsif Lhi <= Rlo then
Set_True;
end if;
when N_Op_Lt =>
if Llo >= Rhi then
Set_False;
elsif Lhi < Rlo then
Set_True;
end if;
when N_Op_Lt =>
if Llo >= Rhi then
Set_False;
elsif Lhi < Rlo then
Set_True;
end if;
when N_Op_Ne =>
if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
Set_False;
elsif Llo > Rhi or else Lhi < Rlo then
Set_True;
end if;
when N_Op_Ne =>
if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
Set_False;
elsif Llo > Rhi or else Lhi < Rlo then
Set_True;
end if;
end case;
-- All done if we did the rewrite
@ -13170,56 +13170,57 @@ package body Exp_Ch4 is
begin
case N_Op_Compare (Nkind (N)) is
when N_Op_Eq =>
True_Result := Res = EQ;
False_Result := Res = LT or else Res = GT or else Res = NE;
when N_Op_Eq =>
True_Result := Res = EQ;
False_Result := Res = LT or else Res = GT or else Res = NE;
when N_Op_Ge =>
True_Result := Res in Compare_GE;
False_Result := Res = LT;
when N_Op_Ge =>
True_Result := Res in Compare_GE;
False_Result := Res = LT;
if Res = LE
and then Constant_Condition_Warnings
and then Comes_From_Source (Original_Node (N))
and then Nkind (Original_Node (N)) = N_Op_Ge
and then not In_Instance
and then Is_Integer_Type (Etype (Left_Opnd (N)))
and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
then
Error_Msg_N
("can never be greater than, could replace by ""'=""?c?",
N);
Warning_Generated := True;
end if;
if Res = LE
and then Constant_Condition_Warnings
and then Comes_From_Source (Original_Node (N))
and then Nkind (Original_Node (N)) = N_Op_Ge
and then not In_Instance
and then Is_Integer_Type (Etype (Left_Opnd (N)))
and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
then
Error_Msg_N
("can never be greater than, could replace by "
& """'=""?c?", N);
Warning_Generated := True;
end if;
when N_Op_Gt =>
True_Result := Res = GT;
False_Result := Res in Compare_LE;
when N_Op_Gt =>
True_Result := Res = GT;
False_Result := Res in Compare_LE;
when N_Op_Lt =>
True_Result := Res = LT;
False_Result := Res in Compare_GE;
when N_Op_Lt =>
True_Result := Res = LT;
False_Result := Res in Compare_GE;
when N_Op_Le =>
True_Result := Res in Compare_LE;
False_Result := Res = GT;
when N_Op_Le =>
True_Result := Res in Compare_LE;
False_Result := Res = GT;
if Res = GE
and then Constant_Condition_Warnings
and then Comes_From_Source (Original_Node (N))
and then Nkind (Original_Node (N)) = N_Op_Le
and then not In_Instance
and then Is_Integer_Type (Etype (Left_Opnd (N)))
and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
then
Error_Msg_N
("can never be less than, could replace by ""'=""?c?", N);
Warning_Generated := True;
end if;
if Res = GE
and then Constant_Condition_Warnings
and then Comes_From_Source (Original_Node (N))
and then Nkind (Original_Node (N)) = N_Op_Le
and then not In_Instance
and then Is_Integer_Type (Etype (Left_Opnd (N)))
and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
then
Error_Msg_N
("can never be less than, could replace by ""'=""?c?",
N);
Warning_Generated := True;
end if;
when N_Op_Ne =>
True_Result := Res = NE or else Res = GT or else Res = LT;
False_Result := Res = EQ;
when N_Op_Ne =>
True_Result := Res = NE or else Res = GT or else Res = LT;
False_Result := Res = EQ;
end case;
-- If this is the first iteration, then we actually convert the

18
gcc/ada/exp_ch5.adb

@ -327,7 +327,10 @@ package body Exp_Ch5 is
function Is_Non_Local_Array (Exp : Node_Id) return Boolean is
begin
case Nkind (Exp) is
when N_Indexed_Component | N_Selected_Component | N_Slice =>
when N_Indexed_Component
| N_Selected_Component
| N_Slice
=>
return Is_Non_Local_Array (Prefix (Exp));
when others =>
@ -739,10 +742,15 @@ package body Exp_Ch5 is
end if;
case Cresult is
when LT | LE | EQ => Set_Backwards_OK (N, False);
when GT | GE => Set_Forwards_OK (N, False);
when NE | Unknown => Set_Backwards_OK (N, False);
Set_Forwards_OK (N, False);
when EQ | LE | LT =>
Set_Backwards_OK (N, False);
when GE | GT =>
Set_Forwards_OK (N, False);
when NE | Unknown =>
Set_Backwards_OK (N, False);
Set_Forwards_OK (N, False);
end case;
end if;
end if;

59
gcc/ada/exp_ch6.adb

@ -589,17 +589,22 @@ package body Exp_Ch6 is
function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String is
begin
case Kind is
when BIP_Alloc_Form =>
when BIP_Alloc_Form =>
return "BIPalloc";
when BIP_Storage_Pool =>
when BIP_Storage_Pool =>
return "BIPstoragepool";
when BIP_Finalization_Master =>
return "BIPfinalizationmaster";
when BIP_Task_Master =>
when BIP_Task_Master =>
return "BIPtaskmaster";
when BIP_Activation_Chain =>
when BIP_Activation_Chain =>
return "BIPactivationchain";
when BIP_Object_Access =>
when BIP_Object_Access =>
return "BIPaccess";
end case;
end BIP_Formal_Suffix;
@ -3036,7 +3041,6 @@ package body Exp_Ch6 is
else
case Nkind (Prev_Orig) is
when N_Attribute_Reference =>
case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is
@ -3080,8 +3084,9 @@ package body Exp_Ch6 is
-- Treat the unchecked attributes as library-level
when Attribute_Unchecked_Access |
Attribute_Unrestricted_Access =>
when Attribute_Unchecked_Access
| Attribute_Unrestricted_Access
=>
Add_Extra_Actual
(Make_Integer_Literal (Loc,
Intval => Scope_Depth (Standard_Standard)),
@ -3367,7 +3372,9 @@ package body Exp_Ch6 is
Defer := True;
when N_Object_Declaration | N_Object_Renaming_Declaration =>
when N_Object_Declaration
| N_Object_Renaming_Declaration
=>
declare
Def_Id : constant Entity_Id :=
Defining_Identifier (Ancestor);
@ -3404,8 +3411,8 @@ package body Exp_Ch6 is
Level :=
New_Occurrence_Of
(Extra_Accessibility_Of_Result
(Return_Applies_To
(Return_Statement_Entity (Ancestor))), Loc);
(Return_Applies_To
(Return_Statement_Entity (Ancestor))), Loc);
end if;
when others =>
@ -3422,8 +3429,9 @@ package body Exp_Ch6 is
-- calls to subps whose enclosing scope is unknown (e.g.,
-- Anon_Access_To_Subp_Param.all)?
Level := Make_Integer_Literal (Loc,
Scope_Depth (Current_Scope) + 1);
Level :=
Make_Integer_Literal (Loc,
Intval => Scope_Depth (Current_Scope) + 1);
end if;
Add_Extra_Actual
@ -5210,16 +5218,17 @@ package body Exp_Ch6 is
-- Distinguish the function and non-function cases:
case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is
when E_Function |
E_Generic_Function =>
when E_Function
| E_Generic_Function
=>
Expand_Simple_Function_Return (N);
when E_Procedure |
E_Generic_Procedure |
E_Entry |
E_Entry_Family |
E_Return_Statement =>
when E_Entry
| E_Entry_Family
| E_Generic_Procedure
| E_Procedure
| E_Return_Statement
=>
Expand_Non_Function_Return (N);
when others =>
@ -6735,7 +6744,6 @@ package body Exp_Ch6 is
case Nkind (Discrim_Source) is
when N_Defining_Identifier =>
pragma Assert (Is_Composite_Type (Discrim_Source)
and then Has_Discriminants (Discrim_Source)
and then Is_Constrained (Discrim_Source));
@ -6761,8 +6769,9 @@ package body Exp_Ch6 is
end loop;
end;
when N_Aggregate | N_Extension_Aggregate =>
when N_Aggregate
| N_Extension_Aggregate
=>
-- Unimplemented: extension aggregate case where discrims
-- come from ancestor part, not extension part.
@ -6857,7 +6866,6 @@ package body Exp_Ch6 is
null;
when others =>
declare
Level : constant Node_Id :=
Make_Integer_Literal (Loc,
@ -6875,7 +6883,6 @@ package body Exp_Ch6 is
Set_Etype (Level, Standard_Natural);
Check_Against_Result_Level (Level);
end;
end case;
end;
end if;

63
gcc/ada/exp_ch7.adb

@ -6061,8 +6061,9 @@ package body Exp_Ch7 is
-- context of a Timed_Entry_Call. In this case we wrap the entire
-- timed entry call.
when N_Entry_Call_Statement |
N_Procedure_Call_Statement =>
when N_Entry_Call_Statement
| N_Procedure_Call_Statement
=>
if Nkind (Parent (The_Parent)) = N_Entry_Call_Alternative
and then Nkind_In (Parent (Parent (The_Parent)),
N_Timed_Entry_Call,
@ -6077,34 +6078,35 @@ package body Exp_Ch7 is
-- even if they are not really wrapped. For further details, see
-- Wrap_Transient_Declaration.
when N_Object_Declaration |
N_Object_Renaming_Declaration |
N_Subtype_Declaration =>
when N_Object_Declaration
| N_Object_Renaming_Declaration
| N_Subtype_Declaration
=>
return The_Parent;
-- The expression itself is to be wrapped if its parent is a
-- compound statement or any other statement where the expression
-- is known to be scalar.
when N_Accept_Alternative |
N_Attribute_Definition_Clause |
N_Case_Statement |
N_Code_Statement |
N_Delay_Alternative |
N_Delay_Until_Statement |
N_Delay_Relative_Statement |
N_Discriminant_Association |
N_Elsif_Part |
N_Entry_Body_Formal_Part |
N_Exit_Statement |
N_If_Statement |
N_Iteration_Scheme |
N_Terminate_Alternative =>
when N_Accept_Alternative
| N_Attribute_Definition_Clause
| N_Case_Statement
| N_Code_Statement
| N_Delay_Alternative
| N_Delay_Until_Statement
| N_Delay_Relative_Statement
| N_Discriminant_Association
| N_Elsif_Part
| N_Entry_Body_Formal_Part
| N_Exit_Statement
| N_If_Statement
| N_Iteration_Scheme
| N_Terminate_Alternative
=>
pragma Assert (Present (P));
return P;
when N_Attribute_Reference =>
if Is_Procedure_Attribute_Name
(Attribute_Name (The_Parent))
then
@ -6128,9 +6130,10 @@ package body Exp_Ch7 is
-- The following nodes contains "dummy calls" which don't need to
-- be wrapped.
when N_Parameter_Specification |
N_Discriminant_Specification |
N_Component_Declaration =>
when N_Component_Declaration
| N_Discriminant_Specification
| N_Parameter_Specification
=>
return Empty;
-- The return statement is not to be wrapped when the function
@ -6155,10 +6158,11 @@ package body Exp_Ch7 is
-- situation that are not detected yet (such as a dynamic string
-- in a pragma export)
when N_Subprogram_Body |
N_Package_Declaration |
N_Package_Body |
N_Block_Statement =>
when N_Block_Statement
| N_Package_Body
| N_Package_Declaration
| N_Subprogram_Body
=>
return Empty;
-- Otherwise continue the search
@ -7655,8 +7659,9 @@ package body Exp_Ch7 is
when Address_Case =>
return Make_Finalize_Address_Stmts (Typ);
when Adjust_Case |
Finalize_Case =>
when Adjust_Case
| Finalize_Case
=>
return Build_Adjust_Or_Finalize_Statements (Typ);
when Initialize_Case =>

62
gcc/ada/exp_ch9.adb

@ -4620,12 +4620,12 @@ package body Exp_Ch9 is
-- Some additional statements for protected entry calls
-- Protected_Entry_Call (
-- Object => po._object'Access,
-- E => <entry index>;
-- Uninterpreted_Data => P'Address;
-- Mode => Simple_Call;
-- Block => Bnn);
-- Protected_Entry_Call
-- (Object => po._object'Access,
-- E => <entry index>;
-- Uninterpreted_Data => P'Address;
-- Mode => Simple_Call;
-- Block => Bnn);
Call :=
Make_Procedure_Call_Statement (Loc,
@ -4642,9 +4642,10 @@ package body Exp_Ch9 is
New_Occurrence_Of (Comm_Name, Loc)));
when System_Tasking_Protected_Objects_Single_Entry =>
-- Protected_Single_Entry_Call (
-- Object => po._object'Access,
-- Uninterpreted_Data => P'Address);
-- Protected_Single_Entry_Call
-- (Object => po._object'Access,
-- Uninterpreted_Data => P'Address);
Call :=
Make_Procedure_Call_Statement (Loc,
@ -6020,23 +6021,25 @@ package body Exp_Ch9 is
function Is_Pure_Barrier (N : Node_Id) return Traverse_Result is
begin
case Nkind (N) is
when N_Expanded_Name |
N_Identifier =>
when N_Expanded_Name
| N_Identifier
=>
if No (Entity (N)) then
return Abandon;
end if;
case Ekind (Entity (N)) is
when E_Constant |
E_Discriminant |
E_Named_Integer |
E_Named_Real |
E_Enumeration_Literal =>
when E_Constant
| E_Discriminant
| E_Enumeration_Literal
| E_Named_Integer
| E_Named_Real
=>
return OK;
when E_Component |
E_Variable =>
when E_Component
| E_Variable
=>
-- A variable in the protected type is expanded as a
-- component.
@ -6048,13 +6051,15 @@ package body Exp_Ch9 is
null;
end case;
when N_Integer_Literal |
N_Real_Literal |
N_Character_Literal =>
when N_Character_Literal
| N_Integer_Literal
| N_Real_Literal
=>
return OK;
when N_Op_Boolean |
N_Op_Not =>
when N_Op_Boolean
| N_Op_Not
=>
if Ekind (Entity (N)) = E_Operator then
return OK;
end if;
@ -8551,7 +8556,6 @@ package body Exp_Ch9 is
when others =>
raise Program_Error;
end case;
Next (Op_Body);
@ -12771,7 +12775,6 @@ package body Exp_Ch9 is
when others =>
raise Program_Error;
end case;
end loop;
@ -13406,8 +13409,8 @@ package body Exp_Ch9 is
High := Type_High_Bound (Etype (Index));
Low := Type_Low_Bound (Etype (Index));
-- In the simple case the entry family is given by a subtype
-- mark and the index constant has the same type.
-- In the simple case the entry family is given by a subtype mark
-- and the index constant has the same type.
if Is_Entity_Name (Original_Node (
Discrete_Subtype_Definition (Parent (Index))))
@ -13832,7 +13835,7 @@ package body Exp_Ch9 is
Called_Subp := RE_Initialize_Protection;
when others =>
raise Program_Error;
raise Program_Error;
end case;
-- Entry_Queue_Maxes parameter. This is an access to an array of
@ -14645,7 +14648,6 @@ package body Exp_Ch9 is
when others =>
return False;
end case;
end Trivial_Accept_OK;

1
gcc/ada/exp_dbug.adb

@ -378,7 +378,6 @@ package body Exp_Dbug is
Ren := Nam;
loop
case Nkind (Ren) is
when N_Identifier =>
exit;

6
gcc/ada/exp_disp.adb

@ -3448,9 +3448,9 @@ package body Exp_Disp is
(RTE (RE_Protected_Entry_Index), Loc),
Expression => Make_Identifier (Loc, Name_uI)),
Make_Identifier (Loc, Name_uP), -- parameter block
Make_Identifier (Loc, Name_uD), -- delay
Make_Identifier (Loc, Name_uM), -- delay mode
Make_Identifier (Loc, Name_uP), -- parameter block
Make_Identifier (Loc, Name_uD), -- delay
Make_Identifier (Loc, Name_uM), -- delay mode
Make_Identifier (Loc, Name_uF)))); -- status flag
when others =>

18
gcc/ada/exp_dist.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
@ -504,7 +504,7 @@ package body Exp_Dist is
-- An expression whose value is a PolyORB reference to the target
-- object.
when others =>
when others =>
Partition : Entity_Id;
-- A variable containing the Partition_ID of the target partition
@ -996,6 +996,7 @@ package body Exp_Dist is
when others =>
null;
end case;
Next (Decl);
end loop;
end Build_Package_Stubs;
@ -2658,6 +2659,7 @@ package body Exp_Dist is
case Get_PCS_Name is
when Name_PolyORB_DSA =>
return Make_String_Literal (Loc, Get_Subprogram_Id (E));
when others =>
return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
end case;
@ -2761,8 +2763,9 @@ package body Exp_Dist is
end if;
case Nkind (Spec) is
when N_Function_Specification | N_Access_Function_Definition =>
when N_Access_Function_Definition
| N_Function_Specification
=>
return
Make_Function_Specification (Loc,
Defining_Unit_Name =>
@ -2772,7 +2775,9 @@ package body Exp_Dist is
Result_Definition =>
New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
when N_Procedure_Specification | N_Access_Procedure_Definition =>
when N_Access_Procedure_Definition
| N_Procedure_Specification
=>
return
Make_Procedure_Specification (Loc,
Defining_Unit_Name =>
@ -11347,6 +11352,7 @@ package body Exp_Dist is
when Name_PolyORB_DSA =>
PolyORB_Support.Add_Obj_RPC_Receiver_Completion
(Loc, Decls, RPC_Receiver, Stub_Elements);
when others =>
GARLIC_Support.Add_Obj_RPC_Receiver_Completion
(Loc, Decls, RPC_Receiver, Stub_Elements);
@ -11398,6 +11404,7 @@ package body Exp_Dist is
case Get_PCS_Name is
when Name_PolyORB_DSA =>
PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
when others =>
GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
end case;
@ -11417,6 +11424,7 @@ package body Exp_Dist is
when Name_PolyORB_DSA =>
PolyORB_Support.Add_Receiving_Stubs_To_Declarations
(Pkg_Spec, Decls, Stmts);
when others =>
GARLIC_Support.Add_Receiving_Stubs_To_Declarations
(Pkg_Spec, Decls, Stmts);

14
gcc/ada/exp_intr.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
@ -319,14 +319,10 @@ package body Exp_Intr is
Set_Etype (Res, T3);
case Nkind (N) is
when N_Op_And =>
Set_Entity (Res, Standard_Op_And);
when N_Op_Or =>
Set_Entity (Res, Standard_Op_Or);
when N_Op_Xor =>
Set_Entity (Res, Standard_Op_Xor);
when others =>
raise Program_Error;
when N_Op_And => Set_Entity (Res, Standard_Op_And);
when N_Op_Or => Set_Entity (Res, Standard_Op_Or);
when N_Op_Xor => Set_Entity (Res, Standard_Op_Xor);
when others => raise Program_Error;
end case;
-- Convert operands to large enough intermediate type

1
gcc/ada/exp_prag.adb

@ -215,7 +215,6 @@ package body Exp_Prag is
when others => null;
end case;
end Expand_N_Pragma;
-------------------------------

20
gcc/ada/exp_spark.adb

@ -67,17 +67,19 @@ package body Exp_SPARK is
-- user interaction. The verification back-end already takes care
-- of qualifying names when needed.
when N_Block_Statement |
N_Entry_Declaration |
N_Package_Body |
N_Package_Declaration |
N_Protected_Type_Declaration |
N_Subprogram_Body |
N_Task_Type_Declaration =>
when N_Block_Statement
| N_Entry_Declaration
| N_Package_Body
| N_Package_Declaration
| N_Protected_Type_Declaration
| N_Subprogram_Body
| N_Task_Type_Declaration
=>
Qualify_Entity_Names (N);
when N_Expanded_Name |
N_Identifier =>
when N_Expanded_Name
| N_Identifier
=>
Expand_SPARK_Potential_Renaming (N);
when N_Object_Renaming_Declaration =>

634
gcc/ada/exp_util.adb

@ -224,34 +224,35 @@ package body Exp_Util is
begin
case Nkind (Parent (N)) is
-- Check for cases of appearing in the prefix of a construct where
-- we don't need atomic synchronization for this kind of usage.
-- Check for cases of appearing in the prefix of a construct where we
-- don't need atomic synchronization for this kind of usage.
when
-- Nothing to do if we are the prefix of an attribute, since we
-- do not want an atomic sync operation for things like 'Size.
-- Nothing to do if we are the prefix of an attribute, since we
-- do not want an atomic sync operation for things like 'Size.
N_Attribute_Reference |
N_Attribute_Reference
-- The N_Reference node is like an attribute
-- The N_Reference node is like an attribute
N_Reference |
| N_Reference
-- Nothing to do for a reference to a component (or components)
-- of a composite object. Only reads and updates of the object
-- as a whole require atomic synchronization (RM C.6 (15)).
N_Indexed_Component |
N_Selected_Component |
N_Slice =>
-- Nothing to do for a reference to a component (or components)
-- of a composite object. Only reads and updates of the object
-- as a whole require atomic synchronization (RM C.6 (15)).
| N_Indexed_Component
| N_Selected_Component
| N_Slice
=>
-- For all the above cases, nothing to do if we are the prefix
if Prefix (Parent (N)) = N then
return;
end if;
when others => null;
when others =>
null;
end case;
-- Nothing to do for the identifier in an object renaming declaration,
@ -272,10 +273,14 @@ package body Exp_Util is
when N_Identifier =>
Msg_Node := N;
when N_Selected_Component | N_Expanded_Name =>
when N_Expanded_Name
| N_Selected_Component
=>
Msg_Node := Selector_Name (N);
when N_Explicit_Dereference | N_Indexed_Component =>
when N_Explicit_Dereference
| N_Indexed_Component
=>
Msg_Node := Empty;
when others =>
@ -5224,20 +5229,11 @@ package body Exp_Util is
P := Node;
while Present (P) loop
case Nkind (P) is
when N_Subprogram_Body =>
return True;
when N_If_Statement =>
return False;
when N_Loop_Statement =>
return False;
when N_Case_Statement =>
return False;
when others =>
P := Parent (P);
when N_Subprogram_Body => return True;
when N_If_Statement => return False;
when N_Loop_Statement => return False;
when N_Case_Statement => return False;
when others => P := Parent (P);
end case;
end loop;
@ -5533,8 +5529,8 @@ package body Exp_Util is
-- They will be moved further out when the while loop or elsif
-- is analyzed.
when N_Iteration_Scheme |
N_Elsif_Part
when N_Elsif_Part
| N_Iteration_Scheme
=>
if N = Condition (P) then
if Present (Condition_Actions (P)) then
@ -5561,73 +5557,73 @@ package body Exp_Util is
when
-- Statements
N_Procedure_Call_Statement |
N_Statement_Other_Than_Procedure_Call |
N_Procedure_Call_Statement
| N_Statement_Other_Than_Procedure_Call
-- Pragmas
N_Pragma |
| N_Pragma
-- Representation_Clause
N_At_Clause |
N_Attribute_Definition_Clause |
N_Enumeration_Representation_Clause |
N_Record_Representation_Clause |
| N_At_Clause
| N_Attribute_Definition_Clause
| N_Enumeration_Representation_Clause
| N_Record_Representation_Clause
-- Declarations
N_Abstract_Subprogram_Declaration |
N_Entry_Body |
N_Exception_Declaration |
N_Exception_Renaming_Declaration |
N_Expression_Function |
N_Formal_Abstract_Subprogram_Declaration |
N_Formal_Concrete_Subprogram_Declaration |
N_Formal_Object_Declaration |
N_Formal_Type_Declaration |
N_Full_Type_Declaration |
N_Function_Instantiation |
N_Generic_Function_Renaming_Declaration |
N_Generic_Package_Declaration |
N_Generic_Package_Renaming_Declaration |
N_Generic_Procedure_Renaming_Declaration |
N_Generic_Subprogram_Declaration |
N_Implicit_Label_Declaration |
N_Incomplete_Type_Declaration |
N_Number_Declaration |
N_Object_Declaration |
N_Object_Renaming_Declaration |
N_Package_Body |
N_Package_Body_Stub |
N_Package_Declaration |
N_Package_Instantiation |
N_Package_Renaming_Declaration |
N_Private_Extension_Declaration |
N_Private_Type_Declaration |
N_Procedure_Instantiation |
N_Protected_Body |
N_Protected_Body_Stub |
N_Protected_Type_Declaration |
N_Single_Task_Declaration |
N_Subprogram_Body |
N_Subprogram_Body_Stub |
N_Subprogram_Declaration |
N_Subprogram_Renaming_Declaration |
N_Subtype_Declaration |
N_Task_Body |
N_Task_Body_Stub |
N_Task_Type_Declaration |
| N_Abstract_Subprogram_Declaration
| N_Entry_Body
| N_Exception_Declaration
| N_Exception_Renaming_Declaration
| N_Expression_Function
| N_Formal_Abstract_Subprogram_Declaration
| N_Formal_Concrete_Subprogram_Declaration
| N_Formal_Object_Declaration
| N_Formal_Type_Declaration
| N_Full_Type_Declaration
| N_Function_Instantiation
| N_Generic_Function_Renaming_Declaration
| N_Generic_Package_Declaration
| N_Generic_Package_Renaming_Declaration
| N_Generic_Procedure_Renaming_Declaration
| N_Generic_Subprogram_Declaration
| N_Implicit_Label_Declaration
| N_Incomplete_Type_Declaration
| N_Number_Declaration
| N_Object_Declaration
| N_Object_Renaming_Declaration
| N_Package_Body
| N_Package_Body_Stub
| N_Package_Declaration
| N_Package_Instantiation
| N_Package_Renaming_Declaration
| N_Private_Extension_Declaration
| N_Private_Type_Declaration
| N_Procedure_Instantiation
| N_Protected_Body
| N_Protected_Body_Stub
| N_Protected_Type_Declaration
| N_Single_Task_Declaration
| N_Subprogram_Body
| N_Subprogram_Body_Stub
| N_Subprogram_Declaration
| N_Subprogram_Renaming_Declaration
| N_Subtype_Declaration
| N_Task_Body
| N_Task_Body_Stub
| N_Task_Type_Declaration
-- Use clauses can appear in lists of declarations
N_Use_Package_Clause |
N_Use_Type_Clause |
| N_Use_Package_Clause
| N_Use_Type_Clause
-- Freeze entity behaves like a declaration or statement
N_Freeze_Entity |
N_Freeze_Generic_Entity
| N_Freeze_Entity
| N_Freeze_Generic_Entity
=>
-- Do not insert here if the item is not a list member (this
-- happens for example with a triggering statement, and the
@ -5685,23 +5681,22 @@ package body Exp_Util is
-- or a subexpression. We tell the difference by looking at the
-- Etype. It is set to Standard_Void_Type in the statement case.
when
N_Raise_xxx_Error =>
if Etype (P) = Standard_Void_Type then
if P = Wrapped_Node then
Store_Before_Actions_In_Scope (Ins_Actions);
else
Insert_List_Before_And_Analyze (P, Ins_Actions);
end if;
return;
-- In the subexpression case, keep climbing
when N_Raise_xxx_Error =>
if Etype (P) = Standard_Void_Type then
if P = Wrapped_Node then
Store_Before_Actions_In_Scope (Ins_Actions);
else
null;
Insert_List_Before_And_Analyze (P, Ins_Actions);
end if;
return;
-- In the subexpression case, keep climbing
else
null;
end if;
-- If a component association appears within a loop created for
-- an array aggregate, attach the actions to the association so
-- they can be subsequently inserted within the loop. For other
@ -5724,7 +5719,6 @@ package body Exp_Util is
if Is_Empty_List (Loop_Actions (P)) then
Set_Loop_Actions (P, Ins_Actions);
Analyze_List (Ins_Actions);
else
declare
Decl : Node_Id;
@ -5761,23 +5755,22 @@ package body Exp_Util is
-- Another special case, an attribute denoting a procedure call
when
N_Attribute_Reference =>
if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
if P = Wrapped_Node then
Store_Before_Actions_In_Scope (Ins_Actions);
else
Insert_List_Before_And_Analyze (P, Ins_Actions);
end if;
return;
-- In the subexpression case, keep climbing
when N_Attribute_Reference =>
if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
if P = Wrapped_Node then
Store_Before_Actions_In_Scope (Ins_Actions);
else
null;
Insert_List_Before_And_Analyze (P, Ins_Actions);
end if;
return;
-- In the subexpression case, keep climbing
else
null;
end if;
-- A contract node should not belong to the tree
when N_Contract =>
@ -5785,153 +5778,151 @@ package body Exp_Util is
-- For all other node types, keep climbing tree
when
N_Abortable_Part |
N_Accept_Alternative |
N_Access_Definition |
N_Access_Function_Definition |
N_Access_Procedure_Definition |
N_Access_To_Object_Definition |
N_Aggregate |
N_Allocator |
N_Aspect_Specification |
N_Case_Expression |
N_Case_Statement_Alternative |
N_Character_Literal |
N_Compilation_Unit |
N_Compilation_Unit_Aux |
N_Component_Clause |
N_Component_Declaration |
N_Component_Definition |
N_Component_List |
N_Constrained_Array_Definition |
N_Decimal_Fixed_Point_Definition |
N_Defining_Character_Literal |
N_Defining_Identifier |
N_Defining_Operator_Symbol |
N_Defining_Program_Unit_Name |
N_Delay_Alternative |
N_Delta_Constraint |
N_Derived_Type_Definition |
N_Designator |
N_Digits_Constraint |
N_Discriminant_Association |
N_Discriminant_Specification |
N_Empty |
N_Entry_Body_Formal_Part |
N_Entry_Call_Alternative |
N_Entry_Declaration |
N_Entry_Index_Specification |
N_Enumeration_Type_Definition |
N_Error |
N_Exception_Handler |
N_Expanded_Name |
N_Explicit_Dereference |
N_Extension_Aggregate |
N_Floating_Point_Definition |
N_Formal_Decimal_Fixed_Point_Definition |
N_Formal_Derived_Type_Definition |
N_Formal_Discrete_Type_Definition |
N_Formal_Floating_Point_Definition |
N_Formal_Modular_Type_Definition |
N_Formal_Ordinary_Fixed_Point_Definition |
N_Formal_Package_Declaration |
N_Formal_Private_Type_Definition |
N_Formal_Incomplete_Type_Definition |
N_Formal_Signed_Integer_Type_Definition |
N_Function_Call |
N_Function_Specification |
N_Generic_Association |
N_Handled_Sequence_Of_Statements |
N_Identifier |
N_In |
N_Index_Or_Discriminant_Constraint |
N_Indexed_Component |
N_Integer_Literal |
N_Iterator_Specification |
N_Itype_Reference |
N_Label |
N_Loop_Parameter_Specification |
N_Mod_Clause |
N_Modular_Type_Definition |
N_Not_In |
N_Null |
N_Op_Abs |
N_Op_Add |
N_Op_And |
N_Op_Concat |
N_Op_Divide |
N_Op_Eq |
N_Op_Expon |
N_Op_Ge |
N_Op_Gt |
N_Op_Le |
N_Op_Lt |
N_Op_Minus |
N_Op_Mod |
N_Op_Multiply |
N_Op_Ne |
N_Op_Not |
N_Op_Or |
N_Op_Plus |
N_Op_Rem |
N_Op_Rotate_Left |
N_Op_Rotate_Right |
N_Op_Shift_Left |
N_Op_Shift_Right |
N_Op_Shift_Right_Arithmetic |
N_Op_Subtract |
N_Op_Xor |
N_Operator_Symbol |
N_Ordinary_Fixed_Point_Definition |
N_Others_Choice |
N_Package_Specification |
N_Parameter_Association |
N_Parameter_Specification |
N_Pop_Constraint_Error_Label |
N_Pop_Program_Error_Label |
N_Pop_Storage_Error_Label |
N_Pragma_Argument_Association |
N_Procedure_Specification |
N_Protected_Definition |
N_Push_Constraint_Error_Label |
N_Push_Program_Error_Label |
N_Push_Storage_Error_Label |
N_Qualified_Expression |
N_Quantified_Expression |
N_Raise_Expression |
N_Range |
N_Range_Constraint |
N_Real_Literal |
N_Real_Range_Specification |
N_Record_Definition |
N_Reference |
N_SCIL_Dispatch_Table_Tag_Init |
N_SCIL_Dispatching_Call |
N_SCIL_Membership_Test |
N_Selected_Component |
N_Signed_Integer_Type_Definition |
N_Single_Protected_Declaration |
N_Slice |
N_String_Literal |
N_Subtype_Indication |
N_Subunit |
N_Task_Definition |
N_Terminate_Alternative |
N_Triggering_Alternative |
N_Type_Conversion |
N_Unchecked_Expression |
N_Unchecked_Type_Conversion |
N_Unconstrained_Array_Definition |
N_Unused_At_End |
N_Unused_At_Start |
N_Variant |
N_Variant_Part |
N_Validate_Unchecked_Conversion |
N_With_Clause
when N_Abortable_Part
| N_Accept_Alternative
| N_Access_Definition
| N_Access_Function_Definition
| N_Access_Procedure_Definition
| N_Access_To_Object_Definition
| N_Aggregate
| N_Allocator
| N_Aspect_Specification
| N_Case_Expression
| N_Case_Statement_Alternative
| N_Character_Literal
| N_Compilation_Unit
| N_Compilation_Unit_Aux
| N_Component_Clause
| N_Component_Declaration
| N_Component_Definition
| N_Component_List
| N_Constrained_Array_Definition
| N_Decimal_Fixed_Point_Definition
| N_Defining_Character_Literal
| N_Defining_Identifier
| N_Defining_Operator_Symbol
| N_Defining_Program_Unit_Name
| N_Delay_Alternative
| N_Delta_Constraint
| N_Derived_Type_Definition
| N_Designator
| N_Digits_Constraint
| N_Discriminant_Association
| N_Discriminant_Specification
| N_Empty
| N_Entry_Body_Formal_Part
| N_Entry_Call_Alternative
| N_Entry_Declaration
| N_Entry_Index_Specification
| N_Enumeration_Type_Definition
| N_Error
| N_Exception_Handler
| N_Expanded_Name
| N_Explicit_Dereference
| N_Extension_Aggregate
| N_Floating_Point_Definition
| N_Formal_Decimal_Fixed_Point_Definition
| N_Formal_Derived_Type_Definition
| N_Formal_Discrete_Type_Definition
| N_Formal_Floating_Point_Definition
| N_Formal_Modular_Type_Definition
| N_Formal_Ordinary_Fixed_Point_Definition
| N_Formal_Package_Declaration
| N_Formal_Private_Type_Definition
| N_Formal_Incomplete_Type_Definition
| N_Formal_Signed_Integer_Type_Definition
| N_Function_Call
| N_Function_Specification
| N_Generic_Association
| N_Handled_Sequence_Of_Statements
| N_Identifier
| N_In
| N_Index_Or_Discriminant_Constraint
| N_Indexed_Component
| N_Integer_Literal
| N_Iterator_Specification
| N_Itype_Reference
| N_Label
| N_Loop_Parameter_Specification
| N_Mod_Clause
| N_Modular_Type_Definition
| N_Not_In
| N_Null
| N_Op_Abs
| N_Op_Add
| N_Op_And
| N_Op_Concat
| N_Op_Divide
| N_Op_Eq
| N_Op_Expon
| N_Op_Ge
| N_Op_Gt
| N_Op_Le
| N_Op_Lt
| N_Op_Minus
| N_Op_Mod
| N_Op_Multiply
| N_Op_Ne
| N_Op_Not
| N_Op_Or
| N_Op_Plus
| N_Op_Rem
| N_Op_Rotate_Left
| N_Op_Rotate_Right
| N_Op_Shift_Left
| N_Op_Shift_Right
| N_Op_Shift_Right_Arithmetic
| N_Op_Subtract
| N_Op_Xor
| N_Operator_Symbol
| N_Ordinary_Fixed_Point_Definition
| N_Others_Choice
| N_Package_Specification
| N_Parameter_Association
| N_Parameter_Specification
| N_Pop_Constraint_Error_Label
| N_Pop_Program_Error_Label
| N_Pop_Storage_Error_Label
| N_Pragma_Argument_Association
| N_Procedure_Specification
| N_Protected_Definition
| N_Push_Constraint_Error_Label
| N_Push_Program_Error_Label
| N_Push_Storage_Error_Label
| N_Qualified_Expression
| N_Quantified_Expression
| N_Raise_Expression
| N_Range
| N_Range_Constraint
| N_Real_Literal
| N_Real_Range_Specification
| N_Record_Definition
| N_Reference
| N_SCIL_Dispatch_Table_Tag_Init
| N_SCIL_Dispatching_Call
| N_SCIL_Membership_Test
| N_Selected_Component
| N_Signed_Integer_Type_Definition
| N_Single_Protected_Declaration
| N_Slice
| N_String_Literal
| N_Subtype_Indication
| N_Subunit
| N_Task_Definition
| N_Terminate_Alternative
| N_Triggering_Alternative
| N_Type_Conversion
| N_Unchecked_Expression
| N_Unchecked_Type_Conversion
| N_Unconstrained_Array_Definition
| N_Unused_At_End
| N_Unused_At_Start
| N_Variant
| N_Variant_Part
| N_Validate_Unchecked_Conversion
| N_With_Clause
=>
null;
end case;
-- If we fall through above tests, keep climbing tree
@ -8686,7 +8677,6 @@ package body Exp_Util is
else
return False;
end if;
end case;
end Possible_Bit_Aligned_Component;
@ -8777,11 +8767,11 @@ package body Exp_Util is
-- list and ensure that a finalizer is properly built.
case Nkind (N) is
when N_Elsif_Part |
N_If_Statement |
N_Conditional_Entry_Call |
N_Selective_Accept =>
when N_Conditional_Entry_Call
| N_Elsif_Part
| N_If_Statement
| N_Selective_Accept
=>
-- Check the "then statements" for elsif parts and if statements
if Nkind_In (N, N_Elsif_Part, N_If_Statement)
@ -8813,15 +8803,15 @@ package body Exp_Util is
Analyze (Block);
end if;
when N_Abortable_Part |
N_Accept_Alternative |
N_Case_Statement_Alternative |
N_Delay_Alternative |
N_Entry_Call_Alternative |
N_Exception_Handler |
N_Loop_Statement |
N_Triggering_Alternative =>
when N_Abortable_Part
| N_Accept_Alternative
| N_Case_Statement_Alternative
| N_Delay_Alternative
| N_Entry_Call_Alternative
| N_Exception_Handler
| N_Loop_Statement
| N_Triggering_Alternative
=>
if not Is_Empty_List (Statements (N))
and then not Are_Wrapped (Statements (N))
and then Requires_Cleanup_Actions (Statements (N), False, False)
@ -9042,7 +9032,9 @@ package body Exp_Util is
end if;
case Nkind (N) is
when N_Indexed_Component | N_Slice =>
when N_Indexed_Component
| N_Slice
=>
return
Is_Name_Reference (Prefix (N))
or else Is_Access_Type (Etype (Prefix (N)));
@ -9067,9 +9059,10 @@ package body Exp_Util is
-- A view conversion of a tagged name is a name reference
when N_Type_Conversion =>
return Is_Tagged_Type (Etype (Subtype_Mark (N)))
and then Is_Tagged_Type (Etype (Expression (N)))
and then Is_Name_Reference (Expression (N));
return
Is_Tagged_Type (Etype (Subtype_Mark (N)))
and then Is_Tagged_Type (Etype (Expression (N)))
and then Is_Name_Reference (Expression (N));
-- An unchecked type conversion is considered to be a name if
-- the operand is a name (this construction arises only as a
@ -9578,13 +9571,14 @@ package body Exp_Util is
begin
case Nkind (N) is
when N_Accept_Statement |
N_Block_Statement |
N_Entry_Body |
N_Package_Body |
N_Protected_Body |
N_Subprogram_Body |
N_Task_Body =>
when N_Accept_Statement
| N_Block_Statement
| N_Entry_Body
| N_Package_Body
| N_Protected_Body
| N_Subprogram_Body
| N_Task_Body
=>
return
Requires_Cleanup_Actions (Declarations (N), At_Lib_Level, True)
or else
@ -9602,7 +9596,7 @@ package body Exp_Util is
Requires_Cleanup_Actions
(Private_Declarations (N), At_Lib_Level, True);
when others =>
when others =>
return False;
end case;
end Requires_Cleanup_Actions;
@ -10629,17 +10623,21 @@ package body Exp_Util is
-- Is this right? what about x'first where x is a variable???
when N_Attribute_Reference =>
return Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
and then Attribute_Name (N) /= Name_Input
and then (Is_Entity_Name (Prefix (N))
or else Side_Effect_Free
(Prefix (N), Name_Req, Variable_Ref));
return
Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
and then Attribute_Name (N) /= Name_Input
and then (Is_Entity_Name (Prefix (N))
or else Side_Effect_Free
(Prefix (N), Name_Req, Variable_Ref));
-- A binary operator is side effect free if and both operands are
-- side effect free. For this purpose binary operators include
-- membership tests and short circuit forms.
when N_Binary_Op | N_Membership_Test | N_Short_Circuit =>
when N_Binary_Op
| N_Membership_Test
| N_Short_Circuit
=>
return Side_Effect_Free (Left_Opnd (N), Name_Req, Variable_Ref)
and then
Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
@ -10654,9 +10652,10 @@ package body Exp_Util is
-- is side effect free and it has no actions.
when N_Expression_With_Actions =>
return Is_Empty_List (Actions (N))
and then
Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
return
Is_Empty_List (Actions (N))
and then Side_Effect_Free
(Expression (N), Name_Req, Variable_Ref);
-- A call to _rep_to_pos is side effect free, since we generate
-- this pure function call ourselves. Moreover it is critically
@ -10668,11 +10667,12 @@ package body Exp_Util is
-- All other function calls are not side effect free
when N_Function_Call =>
return Nkind (Name (N)) = N_Identifier
and then Is_TSS (Name (N), TSS_Rep_To_Pos)
and then
Side_Effect_Free
(First (Parameter_Associations (N)), Name_Req, Variable_Ref);
return
Nkind (Name (N)) = N_Identifier
and then Is_TSS (Name (N), TSS_Rep_To_Pos)
and then Side_Effect_Free
(First (Parameter_Associations (N)),
Name_Req, Variable_Ref);
-- An IF expression is side effect free if it's of a scalar type, and
-- all its components are all side effect free (conditions and then
@ -10681,17 +10681,19 @@ package body Exp_Util is
-- where the type involved is a string type.
when N_If_Expression =>
return Is_Scalar_Type (Typ)
and then
Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref);
return
Is_Scalar_Type (Typ)
and then Side_Effect_Free
(Expressions (N), Name_Req, Variable_Ref);
-- An indexed component is side effect free if it is a side
-- effect free prefixed reference and all the indexing
-- expressions are side effect free.
when N_Indexed_Component =>
return Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
and then Safe_Prefixed_Reference (N);
return
Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
and then Safe_Prefixed_Reference (N);
-- A type qualification is side effect free if the expression
-- is side effect free.
@ -10716,9 +10718,9 @@ package body Exp_Util is
-- prefixed reference and the bounds are side effect free.
when N_Slice =>
return Side_Effect_Free
(Discrete_Range (N), Name_Req, Variable_Ref)
and then Safe_Prefixed_Reference (N);
return
Side_Effect_Free (Discrete_Range (N), Name_Req, Variable_Ref)
and then Safe_Prefixed_Reference (N);
-- A type conversion is side effect free if the expression to be
-- converted is side effect free.
@ -10736,9 +10738,10 @@ package body Exp_Util is
-- is safe and its argument is side effect free.
when N_Unchecked_Type_Conversion =>
return Safe_Unchecked_Type_Conversion (N)
and then
Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
return
Safe_Unchecked_Type_Conversion (N)
and then Side_Effect_Free
(Expression (N), Name_Req, Variable_Ref);
-- An unchecked expression is side effect free if its expression
-- is side effect free.
@ -10748,10 +10751,11 @@ package body Exp_Util is
-- A literal is side effect free
when N_Character_Literal |
N_Integer_Literal |
N_Real_Literal |
N_String_Literal =>
when N_Character_Literal
| N_Integer_Literal
| N_Real_Literal
| N_String_Literal
=>
return True;
-- We consider that anything else has side effects. This is a bit

16
gcc/ada/expander.adb

@ -489,7 +489,6 @@ package body Expander is
when others =>
null;
end case;
exception
@ -507,16 +506,19 @@ package body Expander is
if Scope_Is_Transient and then N = Node_To_Be_Wrapped then
case Nkind (N) is
when N_Statement_Other_Than_Procedure_Call |
N_Procedure_Call_Statement =>
when N_Procedure_Call_Statement
| N_Statement_Other_Than_Procedure_Call
=>
Wrap_Transient_Statement (N);
when N_Object_Declaration |
N_Object_Renaming_Declaration |
N_Subtype_Declaration =>
when N_Object_Declaration
| N_Object_Renaming_Declaration
| N_Subtype_Declaration
=>
Wrap_Transient_Declaration (N);
when others => Wrap_Transient_Expression (N);
when others =>
Wrap_Transient_Expression (N);
end case;
end if;

77
gcc/ada/freeze.adb

@ -2250,7 +2250,8 @@ package body Freeze is
return OK;
end if;
when others => return OK;
when others =>
return OK;
end case;
end Process;
@ -3451,12 +3452,11 @@ package body Freeze is
R_Type := Etype (E);
-- AI05-0151: the return type may have been incomplete
-- at the point of declaration. Replace it with the full
-- view, unless the current type is a limited view. In
-- that case the full view is in a different unit, and
-- gigi finds the non-limited view after the other unit
-- is elaborated.
-- AI05-0151: the return type may have been incomplete at the
-- point of declaration. Replace it with the full view, unless the
-- current type is a limited view. In that case the full view is
-- in a different unit, and gigi finds the non-limited view after
-- the other unit is elaborated.
if Ekind (R_Type) = E_Incomplete_Type
and then Present (Full_View (R_Type))
@ -3483,8 +3483,9 @@ package body Freeze is
and then not Has_Warnings_Off (E)
and then not Has_Warnings_Off (R_Type)
then
Error_Msg_N ("?x?return type of& does not "
& "correspond to C pointer!", E);
Error_Msg_N
("?x?return type of& does not correspond to C pointer!",
E);
-- Check suspicious return of boolean
@ -6787,10 +6788,10 @@ package body Freeze is
Desig_Typ := Find_Aggregate_Component_Desig_Type;
end if;
when N_Selected_Component |
N_Indexed_Component |
N_Slice =>
when N_Indexed_Component
| N_Selected_Component
| N_Slice
=>
if Is_Access_Type (Etype (Prefix (N))) then
Desig_Typ := Designated_Type (Etype (Prefix (N)));
end if;
@ -7002,35 +7003,37 @@ package body Freeze is
-- is a statement or declaration and we can insert the freeze node
-- before it.
when N_Block_Statement |
N_Entry_Body |
N_Package_Body |
N_Package_Specification |
N_Protected_Body |
N_Subprogram_Body |
N_Task_Body => exit;
when N_Block_Statement
| N_Entry_Body
| N_Package_Body
| N_Package_Specification
| N_Protected_Body
| N_Subprogram_Body
| N_Task_Body
=>
exit;
-- The expander is allowed to define types in any statements list,
-- so any of the following parent nodes also mark a freezing point
-- if the actual node is in a list of statements or declarations.
when N_Abortable_Part |
N_Accept_Alternative |
N_And_Then |
N_Case_Statement_Alternative |
N_Compilation_Unit_Aux |
N_Conditional_Entry_Call |
N_Delay_Alternative |
N_Elsif_Part |
N_Entry_Call_Alternative |
N_Exception_Handler |
N_Extended_Return_Statement |
N_Freeze_Entity |
N_If_Statement |
N_Or_Else |
N_Selective_Accept |
N_Triggering_Alternative =>
when N_Abortable_Part
| N_Accept_Alternative
| N_And_Then
| N_Case_Statement_Alternative
| N_Compilation_Unit_Aux
| N_Conditional_Entry_Call
| N_Delay_Alternative
| N_Elsif_Part
| N_Entry_Call_Alternative
| N_Exception_Handler
| N_Extended_Return_Statement
| N_Freeze_Entity
| N_If_Statement
| N_Or_Else
| N_Selective_Accept
| N_Triggering_Alternative
=>
exit when Is_List_Member (P);
-- Freeze nodes produced by an expression coming from the Actions

4
gcc/ada/g-arrspl.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2013, Free Software Foundation, Inc. --
-- Copyright (C) 2002-2016, 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- --
@ -294,7 +294,6 @@ package body GNAT.Array_Split is
exit when K > Count_Sep;
case Mode is
when Single =>
-- In this mode just set start to character next to the
@ -313,7 +312,6 @@ package body GNAT.Array_Split is
exit when K > Count_Sep
or else S.D.Indexes (K) > S.D.Indexes (K - 1) + 1;
end loop;
end case;
end loop;

4
gcc/ada/g-awk.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2000-2014, AdaCore --
-- Copyright (C) 2000-2016, AdaCore --
-- --
-- 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- --
@ -974,7 +974,6 @@ package body GNAT.AWK is
Split_Line (Session);
case Callbacks is
when None =>
exit;
@ -985,7 +984,6 @@ package body GNAT.AWK is
when Pass_Through =>
Filter_Active := Apply_Filters (Session);
exit;
end case;
end loop;
end Get_Line;

3
gcc/ada/g-catiio.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2014, AdaCore --
-- Copyright (C) 1999-2016, AdaCore --
-- --
-- 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- --
@ -500,7 +500,6 @@ package body GNAT.Calendar.Time_IO is
when others =>
raise Picture_Error with
"unknown format character in picture string";
end case;
-- Skip past % and format character

17
gcc/ada/g-comlin.adb

@ -483,18 +483,22 @@ package body GNAT.Command_Line is
end if;
case Switch (Switch'Last) is
when ':' =>
when ':' =>
Parameter_Type := Parameter_With_Optional_Space;
Switch_Last := Switch'Last - 1;
when '=' =>
when '=' =>
Parameter_Type := Parameter_With_Space_Or_Equal;
Switch_Last := Switch'Last - 1;
when '!' =>
when '!' =>
Parameter_Type := Parameter_No_Space;
Switch_Last := Switch'Last - 1;
when '?' =>
when '?' =>
Parameter_Type := Parameter_Optional;
Switch_Last := Switch'Last - 1;
when others =>
Parameter_Type := Parameter_None;
Switch_Last := Switch'Last;
@ -2068,7 +2072,9 @@ package body GNAT.Command_Line is
Found_In_Config := True;
return False;
when Parameter_No_Space | Parameter_Optional =>
when Parameter_No_Space
| Parameter_Optional
=>
Callback (Switch (Switch'First .. Last),
"", Switch (Param .. Switch'Last), Index);
Found_In_Config := True;
@ -3407,7 +3413,6 @@ package body GNAT.Command_Line is
Config.Switches (Index).String_Output.all :=
new String'(Parameter);
return;
end case;
end if;

43
gcc/ada/g-debpoo.adb

@ -1921,21 +1921,27 @@ package body GNAT.Debug_Pools is
begin
Put_Line ("");
case Sort is
when Memory_Usage | All_Reports =>
when All_Reports
| Memory_Usage
=>
Put_Line (Size'Img & " biggest memory users at this time:");
Put_Line ("Results include bytes and chunks still allocated");
Grand_Total := Float (Pool.Current_Water_Mark);
when Allocations_Count =>
Put_Line (Size'Img & " biggest number of live allocations:");
Put_Line ("Results include bytes and chunks still allocated");
Grand_Total := Float (Pool.Current_Water_Mark);
when Sort_Total_Allocs =>
Put_Line (Size'Img & " biggest number of allocations:");
Put_Line ("Results include total bytes and chunks allocated,");
Put_Line ("even if no longer allocated - Deallocations are"
& " ignored");
Grand_Total := Float (Pool.Allocated);
when Marked_Blocks =>
Put_Line ("Special blocks marked by Mark_Traceback");
Grand_Total := 0.0;
@ -1964,16 +1970,22 @@ package body GNAT.Debug_Pools is
Bigger := Max (M) = null;
if not Bigger then
case Sort is
when Memory_Usage | All_Reports =>
Bigger :=
Max (M).Total - Max (M).Total_Frees <
Elem.Total - Elem.Total_Frees;
when Allocations_Count =>
Bigger :=
Max (M).Count - Max (M).Frees
< Elem.Count - Elem.Frees;
when Sort_Total_Allocs | Marked_Blocks =>
Bigger := Max (M).Count < Elem.Count;
when All_Reports
| Memory_Usage
=>
Bigger :=
Max (M).Total - Max (M).Total_Frees
< Elem.Total - Elem.Total_Frees;
when Allocations_Count =>
Bigger :=
Max (M).Count - Max (M).Frees
< Elem.Count - Elem.Frees;
when Marked_Blocks
| Sort_Total_Allocs
=>
Bigger := Max (M).Count < Elem.Count;
end case;
end if;
@ -2001,10 +2013,15 @@ package body GNAT.Debug_Pools is
P : Percent;
begin
case Sort is
when Memory_Usage | Allocations_Count | All_Reports =>
when All_Reports
| Allocations_Count
| Memory_Usage
=>
Total := Max (M).Total - Max (M).Total_Frees;
when Sort_Total_Allocs =>
Total := Max (M).Total;
when Marked_Blocks =>
Total := Byte_Count (Max (M).Count);
end case;
@ -2056,7 +2073,6 @@ package body GNAT.Debug_Pools is
when others =>
Do_Report (Report);
end case;
end Dump;
-----------------
@ -2068,7 +2084,6 @@ package body GNAT.Debug_Pools is
Size : Positive;
Report : Report_Type := All_Reports)
is
procedure Internal is new Dump
(Put_Line => Stdout_Put_Line,
Put => Stdout_Put);

29
gcc/ada/g-expect.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2000-2015, AdaCore --
-- Copyright (C) 2000-2016, AdaCore --
-- --
-- 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- --
@ -358,10 +358,14 @@ package body GNAT.Expect is
Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer);
case N is
when Expect_Internal_Error | Expect_Process_Died =>
when Expect_Internal_Error
| Expect_Process_Died
=>
raise Process_Died;
when Expect_Timeout | Expect_Full_Buffer =>
when Expect_Full_Buffer
| Expect_Timeout
=>
Result := N;
return;
@ -514,10 +518,14 @@ package body GNAT.Expect is
Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
case N is
when Expect_Internal_Error | Expect_Process_Died =>
when Expect_Internal_Error
| Expect_Process_Died
=>
raise Process_Died;
when Expect_Timeout | Expect_Full_Buffer =>
when Expect_Full_Buffer
| Expect_Timeout
=>
Result := N;
return;
@ -576,10 +584,14 @@ package body GNAT.Expect is
Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
case N is
when Expect_Internal_Error | Expect_Process_Died =>
when Expect_Internal_Error
| Expect_Process_Died
=>
raise Process_Died;
when Expect_Timeout | Expect_Full_Buffer =>
when Expect_Full_Buffer
| Expect_Timeout
=>
Result := N;
return;
@ -698,7 +710,6 @@ package body GNAT.Expect is
-- If there is no limit to the buffer size
if Descriptors (D).Buffer_Size = 0 then
declare
Tmp : String_Access := Descriptors (D).Buffer;
@ -728,7 +739,7 @@ package body GNAT.Expect is
-- Add what we read to the buffer
if Descriptors (D).Buffer_Index + N >
Descriptors (D).Buffer_Size
Descriptors (D).Buffer_Size
then
-- If the user wants to know when we have
-- read more than the buffer can contain.

23
gcc/ada/g-forstr.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2014, Free Software Foundation, Inc. --
-- Copyright (C) 2014-2016, 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- --
@ -698,8 +698,9 @@ package body GNAT.Formatted_String is
S := Strings.Fixed.Index_Non_Blank (Buffer);
E := Buffer'Last;
when Decimal_Scientific_Float | Decimal_Scientific_Float_Up =>
when Decimal_Scientific_Float
| Decimal_Scientific_Float_Up
=>
Put (Buffer, Var, Aft, Exp => 3);
S := Strings.Fixed.Index_Non_Blank (Buffer);
E := Buffer'Last;
@ -709,8 +710,9 @@ package body GNAT.Formatted_String is
Characters.Handling.To_Lower (Buffer (S .. E));
end if;
when Shortest_Decimal_Float | Shortest_Decimal_Float_Up =>
when Shortest_Decimal_Float
| Shortest_Decimal_Float_Up
=>
-- Without exponent
Put (Buffer, Var, Aft, Exp => 0);
@ -907,10 +909,10 @@ package body GNAT.Formatted_String is
N'First));
begin
case F.Base is
when None =>
when None =>
null;
when C_Style =>
when C_Style =>
case F.Kind is
when Unsigned_Octal =>
N (P) := 'O';
@ -933,7 +935,7 @@ package body GNAT.Formatted_String is
null;
end case;
when Ada_Style =>
when Ada_Style =>
case F.Kind is
when Unsigned_Octal =>
if F.Left_Justify then
@ -945,8 +947,9 @@ package body GNAT.Formatted_String is
N (N'First .. N'First + 1) := "8#";
N (N'Last) := '#';
when Unsigned_Hexadecimal_Int |
Unsigned_Hexadecimal_Int_Up =>
when Unsigned_Hexadecimal_Int
| Unsigned_Hexadecimal_Int_Up
=>
if F.Left_Justify then
N (N'First + 3 .. N'Last) := N (N'First .. N'Last - 3);
else

3
gcc/ada/g-memdum.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2003-2014, AdaCore --
-- Copyright (C) 2003-2016, AdaCore --
-- --
-- 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- --
@ -133,6 +133,7 @@ package body GNAT.Memory_Dump is
Offset_Buf (4 .. Last - 1);
Line_Buf (AIL - 1 .. AIL) := ": ";
end;
when None =>
null;
end case;

8
gcc/ada/g-pehage.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2015, AdaCore --
-- Copyright (C) 2002-2016, AdaCore --
-- --
-- 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- --
@ -886,7 +886,8 @@ package body GNAT.Perfect_Hash_Generators is
Length_2 := 0;
when Function_Table_1
| Function_Table_2 =>
| Function_Table_2
=>
Item_Size := Type_Size (NV);
Length_1 := T1_Len;
Length_2 := T2_Len;
@ -1675,6 +1676,7 @@ package body GNAT.Perfect_Hash_Generators is
case Opt is
when CPU_Time =>
Put (File, Type_Img (256));
when Memory_Space =>
Put (File, "Natural");
end case;
@ -1693,6 +1695,7 @@ package body GNAT.Perfect_Hash_Generators is
case Opt is
when CPU_Time =>
Put (File, "C");
when Memory_Space =>
Put (File, "Character'Pos");
end case;
@ -2591,7 +2594,6 @@ package body GNAT.Perfect_Hash_Generators is
when Graph_Table =>
return Get_Graph (J);
end case;
end Value;

8
gcc/ada/g-sercom-linux.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2007-2015, AdaCore --
-- Copyright (C) 2007-2016, AdaCore --
-- --
-- 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- --
@ -239,10 +239,12 @@ package body GNAT.Serial_Communications is
end if;
case Flow is
when None =>
when None =>
null;
when RTS_CTS =>
when RTS_CTS =>
Current.c_cflag := Current.c_cflag or CRTSCTS;
when Xon_Xoff =>
Current.c_iflag := Current.c_iflag or IXON;
end case;

119
gcc/ada/g-socket.adb

@ -1169,28 +1169,30 @@ package body GNAT.Sockets is
end if;
case Name is
when Multicast_Loop |
Multicast_TTL |
Receive_Packet_Info =>
when Multicast_Loop
| Multicast_TTL
| Receive_Packet_Info
=>
Len := V1'Size / 8;
Add := V1'Address;
when Generic_Option |
Keep_Alive |
Reuse_Address |
Broadcast |
No_Delay |
Send_Buffer |
Receive_Buffer |
Multicast_If |
Error |
Busy_Polling =>
when Broadcast
| Busy_Polling
| Error
| Generic_Option
| Keep_Alive
| Multicast_If
| No_Delay
| Receive_Buffer
| Reuse_Address
| Send_Buffer
=>
Len := V4'Size / 8;
Add := V4'Address;
when Send_Timeout |
Receive_Timeout =>
when Receive_Timeout
| Send_Timeout
=>
-- The standard argument for SO_RCVTIMEO and SO_SNDTIMEO is a
-- struct timeval, but on Windows it is a milliseconds count in
-- a DWORD.
@ -1204,12 +1206,12 @@ package body GNAT.Sockets is
Add := VT'Address;
end if;
when Linger |
Add_Membership |
Drop_Membership =>
when Add_Membership
| Drop_Membership
| Linger
=>
Len := V8'Size / 8;
Add := V8'Address;
end case;
Res :=
@ -1228,44 +1230,48 @@ package body GNAT.Sockets is
Opt.Optname := Onm;
Opt.Optval := V4;
when Keep_Alive |
Reuse_Address |
Broadcast |
No_Delay =>
when Broadcast
| Keep_Alive
| No_Delay
| Reuse_Address
=>
Opt.Enabled := (V4 /= 0);
when Busy_Polling =>
Opt.Microseconds := Natural (V4);
when Linger =>
when Linger =>
Opt.Enabled := (V8 (V8'First) /= 0);
Opt.Seconds := Natural (V8 (V8'Last));
when Send_Buffer |
Receive_Buffer =>
when Receive_Buffer
| Send_Buffer
=>
Opt.Size := Natural (V4);
when Error =>
when Error =>
Opt.Error := Resolve_Error (Integer (V4));
when Add_Membership |
Drop_Membership =>
when Add_Membership
| Drop_Membership
=>
To_Inet_Addr (To_In_Addr (V8 (V8'First)), Opt.Multicast_Address);
To_Inet_Addr (To_In_Addr (V8 (V8'Last)), Opt.Local_Interface);
when Multicast_If =>
when Multicast_If =>
To_Inet_Addr (To_In_Addr (V4), Opt.Outgoing_If);
when Multicast_TTL =>
when Multicast_TTL =>
Opt.Time_To_Live := Integer (V1);
when Multicast_Loop |
Receive_Packet_Info =>
when Multicast_Loop
| Receive_Packet_Info
=>
Opt.Enabled := (V1 /= 0);
when Send_Timeout |
Receive_Timeout =>
when Receive_Timeout
| Send_Timeout
=>
if Target_OS = Windows then
-- Timeout is in milliseconds, actual value is 500 ms +
@ -2296,10 +2302,11 @@ package body GNAT.Sockets is
Len := V4'Size / 8;
Add := V4'Address;
when Keep_Alive |
Reuse_Address |
Broadcast |
No_Delay =>
when Broadcast
| Keep_Alive
| No_Delay
| Reuse_Address
=>
V4 := C.int (Boolean'Pos (Option.Enabled));
Len := V4'Size / 8;
Add := V4'Address;
@ -2309,49 +2316,52 @@ package body GNAT.Sockets is
Len := V4'Size / 8;
Add := V4'Address;
when Linger =>
when Linger =>
V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled));
V8 (V8'Last) := C.int (Option.Seconds);
Len := V8'Size / 8;
Add := V8'Address;
when Send_Buffer |
Receive_Buffer =>
when Receive_Buffer
| Send_Buffer
=>
V4 := C.int (Option.Size);
Len := V4'Size / 8;
Add := V4'Address;
when Error =>
when Error =>
V4 := C.int (Boolean'Pos (True));
Len := V4'Size / 8;
Add := V4'Address;
when Add_Membership |
Drop_Membership =>
when Add_Membership
| Drop_Membership
=>
V8 (V8'First) := To_Int (To_In_Addr (Option.Multicast_Address));
V8 (V8'Last) := To_Int (To_In_Addr (Option.Local_Interface));
Len := V8'Size / 8;
Add := V8'Address;
when Multicast_If =>
when Multicast_If =>
V4 := To_Int (To_In_Addr (Option.Outgoing_If));
Len := V4'Size / 8;
Add := V4'Address;
when Multicast_TTL =>
when Multicast_TTL =>
V1 := C.unsigned_char (Option.Time_To_Live);
Len := V1'Size / 8;
Add := V1'Address;
when Multicast_Loop |
Receive_Packet_Info =>
when Multicast_Loop
| Receive_Packet_Info
=>
V1 := C.unsigned_char (Boolean'Pos (Option.Enabled));
Len := V1'Size / 8;
Add := V1'Address;
when Send_Timeout |
Receive_Timeout =>
when Receive_Timeout
| Send_Timeout
=>
if Target_OS = Windows then
-- On Windows, the timeout is a DWORD in milliseconds, and
@ -2375,7 +2385,6 @@ package body GNAT.Sockets is
Len := VT'Size / 8;
Add := VT'Address;
end if;
end case;
if Option.Name in Specific_Option_Name then

92
gcc/ada/g-socthi-mingw.adb

@ -569,62 +569,60 @@ package body GNAT.Sockets.Thin is
begin
case Errno is
when EINTR => Errm := Error_Messages (N_EINTR);
when EBADF => Errm := Error_Messages (N_EBADF);
when EACCES => Errm := Error_Messages (N_EACCES);
when EFAULT => Errm := Error_Messages (N_EFAULT);
when EINVAL => Errm := Error_Messages (N_EINVAL);
when EMFILE => Errm := Error_Messages (N_EMFILE);
when EWOULDBLOCK => Errm := Error_Messages (N_EWOULDBLOCK);
when EINPROGRESS => Errm := Error_Messages (N_EINPROGRESS);
when EALREADY => Errm := Error_Messages (N_EALREADY);
when ENOTSOCK => Errm := Error_Messages (N_ENOTSOCK);
when EDESTADDRREQ => Errm := Error_Messages (N_EDESTADDRREQ);
when EMSGSIZE => Errm := Error_Messages (N_EMSGSIZE);
when EPROTOTYPE => Errm := Error_Messages (N_EPROTOTYPE);
when ENOPROTOOPT => Errm := Error_Messages (N_ENOPROTOOPT);
when EPROTONOSUPPORT => Errm := Error_Messages (N_EPROTONOSUPPORT);
when ESOCKTNOSUPPORT => Errm := Error_Messages (N_ESOCKTNOSUPPORT);
when EOPNOTSUPP => Errm := Error_Messages (N_EOPNOTSUPP);
when EPFNOSUPPORT => Errm := Error_Messages (N_EPFNOSUPPORT);
when EAFNOSUPPORT => Errm := Error_Messages (N_EAFNOSUPPORT);
when EADDRINUSE => Errm := Error_Messages (N_EADDRINUSE);
when EADDRNOTAVAIL => Errm := Error_Messages (N_EADDRNOTAVAIL);
when ENETDOWN => Errm := Error_Messages (N_ENETDOWN);
when ENETUNREACH => Errm := Error_Messages (N_ENETUNREACH);
when ENETRESET => Errm := Error_Messages (N_ENETRESET);
when ECONNABORTED => Errm := Error_Messages (N_ECONNABORTED);
when ECONNRESET => Errm := Error_Messages (N_ECONNRESET);
when ENOBUFS => Errm := Error_Messages (N_ENOBUFS);
when EISCONN => Errm := Error_Messages (N_EISCONN);
when ENOTCONN => Errm := Error_Messages (N_ENOTCONN);
when ESHUTDOWN => Errm := Error_Messages (N_ESHUTDOWN);
when ETOOMANYREFS => Errm := Error_Messages (N_ETOOMANYREFS);
when ETIMEDOUT => Errm := Error_Messages (N_ETIMEDOUT);
when ECONNREFUSED => Errm := Error_Messages (N_ECONNREFUSED);
when ELOOP => Errm := Error_Messages (N_ELOOP);
when ENAMETOOLONG => Errm := Error_Messages (N_ENAMETOOLONG);
when EHOSTDOWN => Errm := Error_Messages (N_EHOSTDOWN);
when EHOSTUNREACH => Errm := Error_Messages (N_EHOSTUNREACH);
when EINTR => Errm := Error_Messages (N_EINTR);
when EBADF => Errm := Error_Messages (N_EBADF);
when EACCES => Errm := Error_Messages (N_EACCES);
when EFAULT => Errm := Error_Messages (N_EFAULT);
when EINVAL => Errm := Error_Messages (N_EINVAL);
when EMFILE => Errm := Error_Messages (N_EMFILE);
when EWOULDBLOCK => Errm := Error_Messages (N_EWOULDBLOCK);
when EINPROGRESS => Errm := Error_Messages (N_EINPROGRESS);
when EALREADY => Errm := Error_Messages (N_EALREADY);
when ENOTSOCK => Errm := Error_Messages (N_ENOTSOCK);
when EDESTADDRREQ => Errm := Error_Messages (N_EDESTADDRREQ);
when EMSGSIZE => Errm := Error_Messages (N_EMSGSIZE);
when EPROTOTYPE => Errm := Error_Messages (N_EPROTOTYPE);
when ENOPROTOOPT => Errm := Error_Messages (N_ENOPROTOOPT);
when EPROTONOSUPPORT => Errm := Error_Messages (N_EPROTONOSUPPORT);
when ESOCKTNOSUPPORT => Errm := Error_Messages (N_ESOCKTNOSUPPORT);
when EOPNOTSUPP => Errm := Error_Messages (N_EOPNOTSUPP);
when EPFNOSUPPORT => Errm := Error_Messages (N_EPFNOSUPPORT);
when EAFNOSUPPORT => Errm := Error_Messages (N_EAFNOSUPPORT);
when EADDRINUSE => Errm := Error_Messages (N_EADDRINUSE);
when EADDRNOTAVAIL => Errm := Error_Messages (N_EADDRNOTAVAIL);
when ENETDOWN => Errm := Error_Messages (N_ENETDOWN);
when ENETUNREACH => Errm := Error_Messages (N_ENETUNREACH);
when ENETRESET => Errm := Error_Messages (N_ENETRESET);
when ECONNABORTED => Errm := Error_Messages (N_ECONNABORTED);
when ECONNRESET => Errm := Error_Messages (N_ECONNRESET);
when ENOBUFS => Errm := Error_Messages (N_ENOBUFS);
when EISCONN => Errm := Error_Messages (N_EISCONN);
when ENOTCONN => Errm := Error_Messages (N_ENOTCONN);
when ESHUTDOWN => Errm := Error_Messages (N_ESHUTDOWN);
when ETOOMANYREFS => Errm := Error_Messages (N_ETOOMANYREFS);
when ETIMEDOUT => Errm := Error_Messages (N_ETIMEDOUT);
when ECONNREFUSED => Errm := Error_Messages (N_ECONNREFUSED);
when ELOOP => Errm := Error_Messages (N_ELOOP);
when ENAMETOOLONG => Errm := Error_Messages (N_ENAMETOOLONG);
when EHOSTDOWN => Errm := Error_Messages (N_EHOSTDOWN);
when EHOSTUNREACH => Errm := Error_Messages (N_EHOSTUNREACH);
-- Windows-specific error codes
when WSASYSNOTREADY => Errm := Error_Messages (N_WSASYSNOTREADY);
when WSASYSNOTREADY => Errm := Error_Messages (N_WSASYSNOTREADY);
when WSAVERNOTSUPPORTED =>
Errm := Error_Messages (N_WSAVERNOTSUPPORTED);
when WSANOTINITIALISED =>
when WSANOTINITIALISED =>
Errm := Error_Messages (N_WSANOTINITIALISED);
when WSAEDISCON =>
Errm := Error_Messages (N_WSAEDISCON);
when WSAEDISCON => Errm := Error_Messages (N_WSAEDISCON);
-- h_errno values
when HOST_NOT_FOUND => Errm := Error_Messages (N_HOST_NOT_FOUND);
when TRY_AGAIN => Errm := Error_Messages (N_TRY_AGAIN);
when NO_RECOVERY => Errm := Error_Messages (N_NO_RECOVERY);
when NO_DATA => Errm := Error_Messages (N_NO_DATA);
when others => Errm := Error_Messages (N_OTHERS);
when HOST_NOT_FOUND => Errm := Error_Messages (N_HOST_NOT_FOUND);
when TRY_AGAIN => Errm := Error_Messages (N_TRY_AGAIN);
when NO_RECOVERY => Errm := Error_Messages (N_NO_RECOVERY);
when NO_DATA => Errm := Error_Messages (N_NO_DATA);
when others => Errm := Error_Messages (N_OTHERS);
end case;
return Value (Errm);

332
gcc/ada/g-spipat.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2015, AdaCore --
-- Copyright (C) 1998-2016, AdaCore --
-- --
-- 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- --
@ -220,103 +220,130 @@ package body GNAT.Spitbol.Patterns is
-- Successor element, to be matched after this one
case Pcode is
when PC_Arb_Y
| PC_Assign
| PC_Bal
| PC_BreakX_X
| PC_Cancel
| PC_EOP
| PC_Fail
| PC_Fence
| PC_Fence_X
| PC_Fence_Y
| PC_Null
| PC_R_Enter
| PC_R_Remove
| PC_R_Restore
| PC_Rest
| PC_Succeed
| PC_Unanchored
=>
null;
when PC_Arb_Y |
PC_Assign |
PC_Bal |
PC_BreakX_X |
PC_Cancel |
PC_EOP |
PC_Fail |
PC_Fence |
PC_Fence_X |
PC_Fence_Y |
PC_Null |
PC_R_Enter |
PC_R_Remove |
PC_R_Restore |
PC_Rest |
PC_Succeed |
PC_Unanchored => null;
when PC_Alt
| PC_Arb_X
| PC_Arbno_S
| PC_Arbno_X
=>
Alt : PE_Ptr;
when PC_Alt |
PC_Arb_X |
PC_Arbno_S |
PC_Arbno_X => Alt : PE_Ptr;
when PC_Rpat =>
PP : Pattern_Ptr;
when PC_Rpat => PP : Pattern_Ptr;
when PC_Pred_Func =>
BF : Boolean_Func;
when PC_Pred_Func => BF : Boolean_Func;
when PC_Assign_Imm
| PC_Assign_OnM
| PC_Any_VP
| PC_Break_VP
| PC_BreakX_VP
| PC_NotAny_VP
| PC_NSpan_VP
| PC_Span_VP
| PC_String_VP
=>
VP : VString_Ptr;
when PC_Assign_Imm |
PC_Assign_OnM |
PC_Any_VP |
PC_Break_VP |
PC_BreakX_VP |
PC_NotAny_VP |
PC_NSpan_VP |
PC_Span_VP |
PC_String_VP => VP : VString_Ptr;
when PC_Write_Imm
| PC_Write_OnM
=>
FP : File_Ptr;
when PC_Write_Imm |
PC_Write_OnM => FP : File_Ptr;
when PC_String =>
Str : String_Ptr;
when PC_String => Str : String_Ptr;
when PC_String_2 =>
Str2 : String (1 .. 2);
when PC_String_2 => Str2 : String (1 .. 2);
when PC_String_3 =>
Str3 : String (1 .. 3);
when PC_String_3 => Str3 : String (1 .. 3);
when PC_String_4 =>
Str4 : String (1 .. 4);
when PC_String_4 => Str4 : String (1 .. 4);
when PC_String_5 =>
Str5 : String (1 .. 5);
when PC_String_5 => Str5 : String (1 .. 5);
when PC_String_6 =>
Str6 : String (1 .. 6);
when PC_String_6 => Str6 : String (1 .. 6);
when PC_Setcur =>
Var : Natural_Ptr;
when PC_Setcur => Var : Natural_Ptr;
when PC_Any_CH
| PC_Break_CH
| PC_BreakX_CH
| PC_Char
| PC_NotAny_CH
| PC_NSpan_CH
| PC_Span_CH
=>
Char : Character;
when PC_Any_CH |
PC_Break_CH |
PC_BreakX_CH |
PC_Char |
PC_NotAny_CH |
PC_NSpan_CH |
PC_Span_CH => Char : Character;
when PC_Any_CS
| PC_Break_CS
| PC_BreakX_CS
| PC_NotAny_CS
| PC_NSpan_CS
| PC_Span_CS
=>
CS : Character_Set;
when PC_Any_CS |
PC_Break_CS |
PC_BreakX_CS |
PC_NotAny_CS |
PC_NSpan_CS |
PC_Span_CS => CS : Character_Set;
when PC_Arbno_Y
| PC_Len_Nat
| PC_Pos_Nat
| PC_RPos_Nat
| PC_RTab_Nat
| PC_Tab_Nat
=>
Nat : Natural;
when PC_Arbno_Y |
PC_Len_Nat |
PC_Pos_Nat |
PC_RPos_Nat |
PC_RTab_Nat |
PC_Tab_Nat => Nat : Natural;
when PC_Pos_NF
| PC_Len_NF
| PC_RPos_NF
| PC_RTab_NF
| PC_Tab_NF
=>
NF : Natural_Func;
when PC_Pos_NF |
PC_Len_NF |
PC_RPos_NF |
PC_RTab_NF |
PC_Tab_NF => NF : Natural_Func;
when PC_Pos_NP |
PC_Len_NP |
PC_RPos_NP |
PC_RTab_NP |
PC_Tab_NP => NP : Natural_Ptr;
when PC_Any_VF |
PC_Break_VF |
PC_BreakX_VF |
PC_NotAny_VF |
PC_NSpan_VF |
PC_Span_VF |
PC_String_VF => VF : VString_Func;
when PC_Pos_NP
| PC_Len_NP
| PC_RPos_NP
| PC_RTab_NP
| PC_Tab_NP
=>
NP : Natural_Ptr;
when PC_Any_VF
| PC_Break_VF
| PC_BreakX_VF
| PC_NotAny_VF
| PC_NSpan_VF
| PC_Span_VF
| PC_String_VF
=>
VF : VString_Func;
end case;
end record;
@ -2163,11 +2190,11 @@ package body GNAT.Spitbol.Patterns is
Set_Col (24 + 2 * Count (Cols) + Address_Image_Length);
case E.Pcode is
when PC_Alt |
PC_Arb_X |
PC_Arbno_S |
PC_Arbno_X =>
when PC_Alt
| PC_Arb_X
| PC_Arbno_S
| PC_Arbno_X
=>
Write_Node_Id (E.Alt);
when PC_Rpat =>
@ -2176,19 +2203,21 @@ package body GNAT.Spitbol.Patterns is
when PC_Pred_Func =>
Put (Str_BF (E.BF));
when PC_Assign_Imm |
PC_Assign_OnM |
PC_Any_VP |
PC_Break_VP |
PC_BreakX_VP |
PC_NotAny_VP |
PC_NSpan_VP |
PC_Span_VP |
PC_String_VP =>
when PC_Assign_Imm
| PC_Assign_OnM
| PC_Any_VP
| PC_Break_VP
| PC_BreakX_VP
| PC_NotAny_VP
| PC_NSpan_VP
| PC_Span_VP
| PC_String_VP
=>
Put (Str_VP (E.VP));
when PC_Write_Imm |
PC_Write_OnM =>
when PC_Write_Imm
| PC_Write_OnM
=>
Put (Str_FP (E.FP));
when PC_String =>
@ -2212,56 +2241,62 @@ package body GNAT.Spitbol.Patterns is
when PC_Setcur =>
Put (Str_NP (E.Var));
when PC_Any_CH |
PC_Break_CH |
PC_BreakX_CH |
PC_Char |
PC_NotAny_CH |
PC_NSpan_CH |
PC_Span_CH =>
when PC_Any_CH
| PC_Break_CH
| PC_BreakX_CH
| PC_Char
| PC_NotAny_CH
| PC_NSpan_CH
| PC_Span_CH
=>
Put (''' & E.Char & ''');
when PC_Any_CS |
PC_Break_CS |
PC_BreakX_CS |
PC_NotAny_CS |
PC_NSpan_CS |
PC_Span_CS =>
when PC_Any_CS
| PC_Break_CS
| PC_BreakX_CS
| PC_NotAny_CS
| PC_NSpan_CS
| PC_Span_CS
=>
Put ('"' & To_Sequence (E.CS) & '"');
when PC_Arbno_Y |
PC_Len_Nat |
PC_Pos_Nat |
PC_RPos_Nat |
PC_RTab_Nat |
PC_Tab_Nat =>
when PC_Arbno_Y
| PC_Len_Nat
| PC_Pos_Nat
| PC_RPos_Nat
| PC_RTab_Nat
| PC_Tab_Nat
=>
Put (S (E.Nat));
when PC_Pos_NF |
PC_Len_NF |
PC_RPos_NF |
PC_RTab_NF |
PC_Tab_NF =>
when PC_Pos_NF
| PC_Len_NF
| PC_RPos_NF
| PC_RTab_NF
| PC_Tab_NF
=>
Put (Str_NF (E.NF));
when PC_Pos_NP |
PC_Len_NP |
PC_RPos_NP |
PC_RTab_NP |
PC_Tab_NP =>
when PC_Pos_NP
| PC_Len_NP
| PC_RPos_NP
| PC_RTab_NP
| PC_Tab_NP
=>
Put (Str_NP (E.NP));
when PC_Any_VF |
PC_Break_VF |
PC_BreakX_VF |
PC_NotAny_VF |
PC_NSpan_VF |
PC_Span_VF |
PC_String_VF =>
when PC_Any_VF
| PC_Break_VF
| PC_BreakX_VF
| PC_NotAny_VF
| PC_NSpan_VF
| PC_Span_VF
| PC_String_VF
=>
Put (Str_VF (E.VF));
when others => null;
when others =>
null;
end case;
New_Line;
@ -2409,7 +2444,6 @@ package body GNAT.Spitbol.Patterns is
begin
case E.Pcode is
when PC_Cancel =>
Append (Result, "Cancel");
@ -2668,17 +2702,17 @@ package body GNAT.Spitbol.Patterns is
-- Other pattern codes should not appear as leading elements
when PC_Arb_Y |
PC_Arbno_Y |
PC_Assign |
PC_BreakX_X |
PC_EOP |
PC_Fence_Y |
PC_R_Remove |
PC_R_Restore |
PC_Unanchored =>
when PC_Arb_Y
| PC_Arbno_Y
| PC_Assign
| PC_BreakX_X
| PC_EOP
| PC_Fence_Y
| PC_R_Remove
| PC_R_Restore
| PC_Unanchored
=>
Append (Result, "???");
end case;
E := ER;
@ -3450,7 +3484,6 @@ package body GNAT.Spitbol.Patterns is
when others =>
return new PE'(PC_String, 1, EOP, new String'(Str));
end case;
end S_To_PE;
@ -3998,7 +4031,7 @@ package body GNAT.Spitbol.Patterns is
-- Arb (extension)
when PC_Arb_Y =>
when PC_Arb_Y =>
if Cursor < Length then
Cursor := Cursor + 1;
Push (Node);
@ -4916,7 +4949,6 @@ package body GNAT.Spitbol.Patterns is
Pop_Region;
Assign_OnM := True;
goto Succeed;
end case;
-- We are NOT allowed to fall though this case statement, since every
@ -5315,8 +5347,7 @@ package body GNAT.Spitbol.Patterns is
-- Alternation
when PC_Alt =>
Dout
(Img (Node) & "setting up alternative " & Img (Node.Alt));
Dout (Img (Node) & "setting up alternative " & Img (Node.Alt));
Push (Node.Alt);
Node := Node.Pthen;
goto Match;
@ -6437,7 +6468,6 @@ package body GNAT.Spitbol.Patterns is
Pop_Region;
Assign_OnM := True;
goto Succeed;
end case;
-- We are NOT allowed to fall though this case statement, since every

3
gcc/ada/get_scos.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2009-2014, Free Software Foundation, Inc. --
-- Copyright (C) 2009-2016, 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- --
@ -304,7 +304,6 @@ begin
when others =>
raise Program_Error;
end case;
-- Statement entry

1
gcc/ada/get_spark_xrefs.adb

@ -412,7 +412,6 @@ begin
-- Loop through cross-references for this entity
loop
declare
Line : Nat;
Col : Nat;

2
gcc/ada/gnat1drv.adb

@ -543,9 +543,11 @@ procedure Gnat1drv is
Write_Line
("(requesting support for Frontend ZCX exceptions)");
raise Unrecoverable_Error;
when False =>
Exception_Mechanism := Front_End_SJLJ;
end case;
when False =>
case Targparm.ZCX_By_Default_On_Target is
when True =>

1
gcc/ada/gnatbind.adb

@ -277,7 +277,6 @@ procedure Gnatbind is
when others =>
raise Program_Error;
end case;
end Restriction_Could_Be_Set;

6
gcc/ada/gnatcmd.adb

@ -701,7 +701,11 @@ begin
if Call_GPR_Tool then
case The_Command is
when Make | Compile | Bind | Link =>
when Bind
| Compile
| Link
| Make
=>
if Locate_Exec_On_Path (Gprbuild) /= null then
Program := new String'(Gprbuild);
Get_Target := True;

12
gcc/ada/gnatdll.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1997-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1997-2016, 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- --
@ -271,7 +271,6 @@ procedure Gnatdll is
loop
case Getopt ("g h v q k a? b: d: e: l: n m I:") is
when ASCII.NUL =>
exit;
@ -305,11 +304,9 @@ procedure Gnatdll is
end if;
when 'k' =>
MDLL.Kill_Suffix := True;
when 'a' =>
if Parameter = "" then
-- Default address for a relocatable dynamic library.
@ -324,13 +321,10 @@ procedure Gnatdll is
Must_Build_Relocatable := False;
when 'b' =>
DLL_Address := To_Unbounded_String (Parameter);
Must_Build_Relocatable := True;
when 'e' =>
Def_Filename := To_Unbounded_String (Parameter);
when 'd' =>
@ -347,11 +341,9 @@ procedure Gnatdll is
Build_Mode := Dynamic_Lib;
when 'm' =>
Gen_Map_File := True;
when 'n' =>
Build_Import := False;
when 'l' =>
@ -398,14 +390,12 @@ procedure Gnatdll is
loop
case Getopt ("*") is
when ASCII.NUL =>
exit;
when others =>
Bopts (B) := new String'(Full_Switch);
B := B + 1;
end case;
end loop;

3
gcc/ada/gprep.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2014, Free Software Foundation, Inc. --
-- Copyright (C) 2002-2016, 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- --
@ -729,7 +729,6 @@ package body GPrep is
Switch := GNAT.Command_Line.Getopt ("D: a b c C r s T u v");
case Switch is
when ASCII.NUL =>
exit;

3
gcc/ada/i-cobol.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
@ -543,7 +543,6 @@ package body Interfaces.COBOL is
Val := abs Val;
Convert (1, Length);
Embed_Sign (Length);
end case;
return Result;

37
gcc/ada/layout.adb

@ -668,13 +668,12 @@ package body Layout is
type Val_Status_Type is (Const, Dynamic);
type Val_Type (Status : Val_Status_Type := Const) is
record
case Status is
when Const => Val : Uint;
when Dynamic => Nod : Node_Id;
end case;
end record;
type Val_Type (Status : Val_Status_Type := Const) is record
case Status is
when Const => Val : Uint;
when Dynamic => Nod : Node_Id;
end case;
end record;
-- Shows the status of the value so far. Const means that the value is
-- constant, and Val is the current constant value. Dynamic means that
-- the value is dynamic, and in this case Nod is the Node_Id of the
@ -932,19 +931,19 @@ package body Layout is
type Val_Status_Type is (Const, Dynamic, Discrim);
type Val_Type (Status : Val_Status_Type := Const) is
record
case Status is
when Const =>
Val : Uint;
-- Calculated value so far if Val_Status = Const
type Val_Type (Status : Val_Status_Type := Const) is record
case Status is
when Const =>
Val : Uint;
-- Calculated value so far if Val_Status = Const
when Dynamic | Discrim =>
Nod : Node_Id;
-- Expression value so far if Val_Status /= Const
end case;
end record;
when Discrim
| Dynamic
=>
Nod : Node_Id;
-- Expression value so far if Val_Status /= Const
end case;
end record;
-- Records the value or expression computed so far. Const means that
-- the value is constant, and Val is the current constant value.
-- Dynamic means that the value is dynamic, and in this case Nod is

63
gcc/ada/lib-xref-spark_specific.adb

@ -144,18 +144,20 @@ package body SPARK_Specific is
end if;
case Ekind (E) is
when E_Entry |
E_Entry_Family |
E_Generic_Function |
E_Generic_Package |
E_Generic_Procedure |
E_Package |
E_Protected_Type |
E_Task_Type =>
when E_Entry
| E_Entry_Family
| E_Generic_Function
| E_Generic_Package
| E_Generic_Procedure
| E_Package
| E_Protected_Type
| E_Task_Type
=>
Typ := Xref_Entity_Letters (Ekind (E));
when E_Function | E_Procedure =>
when E_Function
| E_Procedure
=>
-- In SPARK we need to distinguish protected functions and
-- procedures from ordinary subprograms, but there are no
-- special Xref letters for them. Since this distiction is
@ -168,10 +170,11 @@ package body SPARK_Specific is
Typ := Xref_Entity_Letters (Ekind (E));
end if;
when E_Package_Body |
E_Protected_Body |
E_Subprogram_Body |
E_Task_Body =>
when E_Package_Body
| E_Protected_Body
| E_Subprogram_Body
| E_Task_Body
=>
Typ := Xref_Entity_Letters (Ekind (Unique_Entity (E)));
when E_Void =>
@ -456,7 +459,9 @@ package body SPARK_Specific is
end if;
end;
when E_Loop_Parameter | E_In_Parameter =>
when E_In_Parameter
| E_Loop_Parameter
=>
Result := True;
when others =>
@ -1091,9 +1096,9 @@ package body SPARK_Specific is
while Present (Context) loop
case Nkind (Context) is
when N_Package_Body |
N_Package_Specification =>
when N_Package_Body
| N_Package_Specification
=>
-- Only return a library-level package
if Is_Library_Level_Entity (Defining_Entity (Context)) then
@ -1121,14 +1126,15 @@ package body SPARK_Specific is
Context := Parent (Context);
end if;
when N_Entry_Body |
N_Entry_Declaration |
N_Protected_Type_Declaration |
N_Subprogram_Body |
N_Subprogram_Declaration |
N_Subprogram_Specification |
N_Task_Body |
N_Task_Type_Declaration =>
when N_Entry_Body
| N_Entry_Declaration
| N_Protected_Type_Declaration
| N_Subprogram_Body
| N_Subprogram_Declaration
| N_Subprogram_Specification
| N_Task_Body
| N_Task_Type_Declaration
=>
Context := Defining_Entity (Context);
exit;
@ -1317,8 +1323,9 @@ package body SPARK_Specific is
Traverse_Protected_Body (Get_Body_From_Stub (N));
end if;
when N_Protected_Type_Declaration |
N_Single_Protected_Declaration =>
when N_Protected_Type_Declaration
| N_Single_Protected_Declaration
=>
Traverse_Visible_And_Private_Parts (Protected_Definition (N));
when N_Task_Definition =>

13
gcc/ada/live.adb

@ -267,6 +267,7 @@ package body Live is
when others =>
null;
end case;
return OK;
end Process;
@ -305,8 +306,11 @@ package body Live is
begin
case Nkind (N) is
when N_Pragma | N_Generic_Declaration'Range |
N_Subprogram_Declaration | N_Subprogram_Body_Stub =>
when N_Generic_Declaration'Range
| N_Pragma
| N_Subprogram_Body_Stub
| N_Subprogram_Declaration
=>
Result := Skip;
when N_Subprogram_Body =>
@ -319,7 +323,10 @@ package body Live is
Traverse (Proper_Body (Unit (Library_Unit (N))));
end if;
when N_Identifier | N_Operator_Symbol | N_Expanded_Name =>
when N_Expanded_Name
| N_Identifier
| N_Operator_Symbol
=>
E := Entity (N);
if E /= Empty and then not Marked (Marks, E) then

6
gcc/ada/make.adb

@ -2163,15 +2163,15 @@ package body Make is
for Ptr in Template'Range loop
case Template (Ptr) is
when '*' =>
when '*' =>
Add_Str_To_Name_Buffer (Name);
when ';' =>
when ';' =>
File := Full_Lib_File_Name (Name_Find);
exit when File /= No_File;
Name_Len := 0;
when NUL =>
when NUL =>
exit;
when others =>

37
gcc/ada/makeutl.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2016, 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- --
@ -2375,13 +2375,15 @@ package body Makeutl is
begin
case S.Format is
when Format_Gprbuild =>
return not Busy_Obj_Dirs.Get
(S.Id.Project.Object_Directory.Name);
return
not Busy_Obj_Dirs.Get
(S.Id.Project.Object_Directory.Name);
when Format_Gnatmake =>
return S.Project = No_Project
or else
not Busy_Obj_Dirs.Get (S.Project.Object_Directory.Name);
return
S.Project = No_Project
or else not Busy_Obj_Dirs.Get
(S.Project.Object_Directory.Name);
end case;
end Available_Obj_Dir;
@ -2522,10 +2524,11 @@ package body Makeutl is
for J in 1 .. Q.Last loop
case Q.Table (J).Info.Format is
when Format_Gprbuild =>
Q.Table (J).Info.Id.In_The_Queue := False;
when Format_Gnatmake =>
null;
when Format_Gprbuild =>
Q.Table (J).Info.Id.In_The_Queue := False;
when Format_Gnatmake =>
null;
end case;
end loop;
@ -2739,14 +2742,15 @@ package body Makeutl is
if Root_Found then
case Root_Source.Kind is
when Impl =>
null;
when Impl =>
null;
when Spec =>
Root_Found := Other_Part (Root_Source) = No_Source;
when Spec =>
Root_Found :=
Other_Part (Root_Source) = No_Source;
when Sep =>
Root_Found := False;
when Sep =>
Root_Found := False;
end case;
end if;
@ -2886,6 +2890,7 @@ package body Makeutl is
case Q.Table (Rank).Info.Format is
when Format_Gprbuild =>
return Q.Table (Rank).Info.Id.File;
when Format_Gnatmake =>
return Q.Table (Rank).Info.File;
end case;

6
gcc/ada/mlib-prj.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2015, AdaCore --
-- Copyright (C) 2001-2016, AdaCore --
-- --
-- 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- --
@ -1898,7 +1898,9 @@ package body MLib.Prj is
-- Call procedure to build the library, depending on the build mode
case The_Build_Mode is
when Dynamic | Relocatable =>
when Dynamic
| Relocatable
=>
Build_Dynamic_Library
(Ofiles => Object_Files.all,
Options => Options.all,

5
gcc/ada/osint.adb

@ -1977,7 +1977,6 @@ package body Osint is
Dir_Name := new String'(File_Name (File_Name'First .. Fptr - 1));
case Running_Program is
when Compiler =>
Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
Look_In_Primary_Directory_For_Current_Main := True;
@ -1989,7 +1988,9 @@ package body Osint is
Look_In_Primary_Directory_For_Current_Main := True;
end if;
when Binder | Gnatls =>
when Binder
| Gnatls
=>
Dir_Name := Normalize_Directory_Name (Dir_Name.all);
Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;

11
gcc/ada/par-ch12.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
@ -763,10 +763,10 @@ package body Ch12 is
-- Ada 2005 (AI-345): Task, Protected or Synchronized interface or
-- (AI-443): Synchronized formal derived type declaration.
when Tok_Protected |
Tok_Synchronized |
Tok_Task =>
when Tok_Protected
| Tok_Synchronized
| Tok_Task
=>
declare
Saved_Token : constant Token_Type := Token;
@ -812,7 +812,6 @@ package body Ch12 is
Error_Msg_BC ("expecting generic type definition here");
Resync_Past_Semicolon;
return Error;
end case;
end P_Formal_Type_Definition;

42
gcc/ada/par-ch3.adb

@ -464,9 +464,9 @@ package body Ch3 is
loop
case Token is
when Tok_Access |
Tok_Not => -- Ada 2005 (AI-231)
when Tok_Access
| Tok_Not -- Ada 2005 (AI-231)
=>
Typedef_Node := P_Access_Type_Definition;
exit;
@ -777,10 +777,10 @@ package body Ch3 is
-- Ada 2005 (AI-345): Protected, synchronized or task interface
-- or Ada 2005 (AI-443): Synchronized private extension.
when Tok_Protected |
Tok_Synchronized |
Tok_Task =>
when Tok_Protected
| Tok_Synchronized
| Tok_Task
=>
declare
Saved_Token : constant Token_Type := Token;
@ -864,7 +864,6 @@ package body Ch3 is
Error_Msg_AP ("type definition expected");
raise Error_Resync;
end if;
end case;
end loop;
@ -4315,7 +4314,6 @@ package body Ch3 is
end if;
case Token is
when Tok_Function =>
Check_Bad_Layout;
Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
@ -4580,19 +4578,19 @@ package body Ch3 is
-- judgment, because it is a real mess to go into statement mode
-- prematurely in response to a junk declaration.
when Tok_Abort |
Tok_Accept |
Tok_Declare |
Tok_Delay |
Tok_Exit |
Tok_Goto |
Tok_If |
Tok_Loop |
Tok_Null |
Tok_Requeue |
Tok_Select |
Tok_While =>
when Tok_Abort
| Tok_Accept
| Tok_Declare
| Tok_Delay
| Tok_Exit
| Tok_Goto
| Tok_If
| Tok_Loop
| Tok_Null
| Tok_Requeue
| Tok_Select
| Tok_While
=>
-- But before we decide that it's a statement, let's check for
-- a reserved word misused as an identifier.

14
gcc/ada/par-ch4.adb

@ -2583,7 +2583,10 @@ package body Ch4 is
-- that string literal is included in name (as operator symbol)
-- and type conversion is included in name (as indexed component).
when Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier =>
when Tok_Char_Literal
| Tok_Identifier
| Tok_Operator_Symbol
=>
Node1 := P_Name;
-- All done unless apostrophe follows
@ -2624,10 +2627,10 @@ package body Ch4 is
-- Numeric or string literal
when Tok_Integer_Literal |
Tok_Real_Literal |
Tok_String_Literal =>
when Tok_Integer_Literal
| Tok_Real_Literal
| Tok_String_Literal
=>
Node1 := Token_Node;
Scan; -- past number
return Node1;
@ -2797,7 +2800,6 @@ package body Ch4 is
Error_Msg_AP ("missing operand");
raise Error_Resync;
end if;
end case;
end loop;
end P_Primary;

17
gcc/ada/par-ch5.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
@ -342,8 +342,9 @@ package body Ch5 is
-- Case of end or EOF
when Tok_End | Tok_EOF =>
when Tok_End
| Tok_EOF
=>
-- These tokens always terminate the statement sequence
Test_Statement_Required;
@ -459,13 +460,14 @@ package body Ch5 is
-- Case of WHEN (error because we are not in a case)
when Tok_When | Tok_Others =>
when Tok_Others
| Tok_When
=>
-- Terminate if Whtm set or if the WHEN is to the left of
-- the expected column of the end for this sequence.
if SS_Flags.Whtm
or else Start_Column < Scope.Table (Scope.Last).Ecol
or else Start_Column < Scope.Table (Scope.Last).Ecol
then
Test_Statement_Required;
exit;
@ -948,7 +950,6 @@ package body Ch5 is
-- handling of a bad statement.
when others =>
if Token in Token_Class_Declk then
Junk_Declaration;
@ -972,11 +973,9 @@ package body Ch5 is
end;
exit when SS_Flags.Unco;
end loop;
return Statement_List;
end P_Sequence_Of_Statements;
--------------------

449
gcc/ada/par-prag.adb

@ -257,7 +257,9 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
Restriction_Warnings (No_Obsolescent_Features) :=
Prag_Id = Pragma_Restriction_Warnings;
when Name_SPARK | Name_SPARK_05 =>
when Name_SPARK
| Name_SPARK_05
=>
Set_Restriction (SPARK_05, Pragma_Node);
Restriction_Warnings (SPARK_05) :=
Prag_Id = Pragma_Restriction_Warnings;
@ -359,7 +361,9 @@ begin
-- Ada version syntax. However, it is only the zero argument form that
-- must be processed at parse time.
when Pragma_Ada_05 | Pragma_Ada_2005 =>
when Pragma_Ada_05
| Pragma_Ada_2005
=>
if Arg_Count = 0 and not Latest_Ada_Only then
Ada_Version := Ada_2005;
Ada_Version_Explicit := Ada_2005;
@ -375,7 +379,9 @@ begin
-- Ada version syntax. However, it is only the zero argument form that
-- must be processed at parse time.
when Pragma_Ada_12 | Pragma_Ada_2012 =>
when Pragma_Ada_12
| Pragma_Ada_2012
=>
if Arg_Count = 0 then
Ada_Version := Ada_2012;
Ada_Version_Explicit := Ada_2012;
@ -389,7 +395,9 @@ begin
-- This pragma must be processed at parse time, since the resulting
-- status may be tested during the parsing of the program.
when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning =>
when Pragma_Compiler_Unit
| Pragma_Compiler_Unit_Warning
=>
Check_Arg_Count (0);
-- Only recognized in main unit
@ -578,7 +586,9 @@ begin
-- source file names set well before the semantic analysis starts,
-- since we load the spec and with'ed packages before analysis.
when Pragma_Source_File_Name | Pragma_Source_File_Name_Project =>
when Pragma_Source_File_Name
| Pragma_Source_File_Name_Project
=>
Source_File_Name : declare
Unam : Unit_Name_Type;
Expr1 : Node_Id;
@ -1285,220 +1295,221 @@ begin
-- For all other pragmas, checking and processing is handled
-- entirely in Sem_Prag, and no further checking is done by Par.
when Pragma_Abort_Defer |
Pragma_Abstract_State |
Pragma_Async_Readers |
Pragma_Async_Writers |
Pragma_Assertion_Policy |
Pragma_Assume |
Pragma_Assume_No_Invalid_Values |
Pragma_All_Calls_Remote |
Pragma_Allow_Integer_Address |
Pragma_Annotate |
Pragma_Assert |
Pragma_Assert_And_Cut |
Pragma_Asynchronous |
Pragma_Atomic |
Pragma_Atomic_Components |
Pragma_Attach_Handler |
Pragma_Attribute_Definition |
Pragma_Check |
Pragma_Check_Float_Overflow |
Pragma_Check_Name |
Pragma_Check_Policy |
Pragma_Compile_Time_Error |
Pragma_Compile_Time_Warning |
Pragma_Constant_After_Elaboration |
Pragma_Contract_Cases |
Pragma_Convention_Identifier |
Pragma_CPP_Class |
Pragma_CPP_Constructor |
Pragma_CPP_Virtual |
Pragma_CPP_Vtable |
Pragma_CPU |
Pragma_C_Pass_By_Copy |
Pragma_Comment |
Pragma_Common_Object |
Pragma_Complete_Representation |
Pragma_Complex_Representation |
Pragma_Component_Alignment |
Pragma_Controlled |
Pragma_Convention |
Pragma_Debug_Policy |
Pragma_Depends |
Pragma_Detect_Blocking |
Pragma_Default_Initial_Condition |
Pragma_Default_Scalar_Storage_Order |
Pragma_Default_Storage_Pool |
Pragma_Disable_Atomic_Synchronization |
Pragma_Discard_Names |
Pragma_Dispatching_Domain |
Pragma_Effective_Reads |
Pragma_Effective_Writes |
Pragma_Eliminate |
Pragma_Elaborate |
Pragma_Elaborate_All |
Pragma_Elaborate_Body |
Pragma_Elaboration_Checks |
Pragma_Enable_Atomic_Synchronization |
Pragma_Export |
Pragma_Export_Function |
Pragma_Export_Object |
Pragma_Export_Procedure |
Pragma_Export_Value |
Pragma_Export_Valued_Procedure |
Pragma_Extend_System |
Pragma_Extensions_Visible |
Pragma_External |
Pragma_External_Name_Casing |
Pragma_Favor_Top_Level |
Pragma_Fast_Math |
Pragma_Finalize_Storage_Only |
Pragma_Ghost |
Pragma_Global |
Pragma_Ident |
Pragma_Implementation_Defined |
Pragma_Implemented |
Pragma_Implicit_Packing |
Pragma_Import |
Pragma_Import_Function |
Pragma_Import_Object |
Pragma_Import_Procedure |
Pragma_Import_Valued_Procedure |
Pragma_Independent |
Pragma_Independent_Components |
Pragma_Initial_Condition |
Pragma_Initialize_Scalars |
Pragma_Initializes |
Pragma_Inline |
Pragma_Inline_Always |
Pragma_Inline_Generic |
Pragma_Inspection_Point |
Pragma_Interface |
Pragma_Interface_Name |
Pragma_Interrupt_Handler |
Pragma_Interrupt_State |
Pragma_Interrupt_Priority |
Pragma_Invariant |
Pragma_Keep_Names |
Pragma_License |
Pragma_Link_With |
Pragma_Linker_Alias |
Pragma_Linker_Constructor |
Pragma_Linker_Destructor |
Pragma_Linker_Options |
Pragma_Linker_Section |
Pragma_Lock_Free |
Pragma_Locking_Policy |
Pragma_Loop_Invariant |
Pragma_Loop_Optimize |
Pragma_Loop_Variant |
Pragma_Machine_Attribute |
Pragma_Main |
Pragma_Main_Storage |
Pragma_Max_Queue_Length |
Pragma_Memory_Size |
Pragma_No_Body |
Pragma_No_Elaboration_Code_All |
Pragma_No_Inline |
Pragma_No_Return |
Pragma_No_Run_Time |
Pragma_No_Strict_Aliasing |
Pragma_No_Tagged_Streams |
Pragma_Normalize_Scalars |
Pragma_Obsolescent |
Pragma_Ordered |
Pragma_Optimize |
Pragma_Optimize_Alignment |
Pragma_Overflow_Mode |
Pragma_Overriding_Renamings |
Pragma_Pack |
Pragma_Part_Of |
Pragma_Partition_Elaboration_Policy |
Pragma_Passive |
Pragma_Preelaborable_Initialization |
Pragma_Polling |
Pragma_Prefix_Exception_Messages |
Pragma_Persistent_BSS |
Pragma_Post |
Pragma_Postcondition |
Pragma_Post_Class |
Pragma_Pre |
Pragma_Precondition |
Pragma_Predicate |
Pragma_Predicate_Failure |
Pragma_Preelaborate |
Pragma_Pre_Class |
Pragma_Priority |
Pragma_Priority_Specific_Dispatching |
Pragma_Profile |
Pragma_Profile_Warnings |
Pragma_Propagate_Exceptions |
Pragma_Provide_Shift_Operators |
Pragma_Psect_Object |
Pragma_Pure |
Pragma_Pure_Function |
Pragma_Queuing_Policy |
Pragma_Refined_Depends |
Pragma_Refined_Global |
Pragma_Refined_Post |
Pragma_Refined_State |
Pragma_Relative_Deadline |
Pragma_Remote_Access_Type |
Pragma_Remote_Call_Interface |
Pragma_Remote_Types |
Pragma_Restricted_Run_Time |
Pragma_Rational |
Pragma_Ravenscar |
Pragma_Rename_Pragma |
Pragma_Reviewable |
Pragma_Secondary_Stack_Size |
Pragma_Share_Generic |
Pragma_Shared |
Pragma_Shared_Passive |
Pragma_Short_Circuit_And_Or |
Pragma_Short_Descriptors |
Pragma_Simple_Storage_Pool_Type |
Pragma_SPARK_Mode |
Pragma_Storage_Size |
Pragma_Storage_Unit |
Pragma_Static_Elaboration_Desired |
Pragma_Stream_Convert |
Pragma_Subtitle |
Pragma_Suppress |
Pragma_Suppress_Debug_Info |
Pragma_Suppress_Exception_Locations |
Pragma_Suppress_Initialization |
Pragma_System_Name |
Pragma_Task_Dispatching_Policy |
Pragma_Task_Info |
Pragma_Task_Name |
Pragma_Task_Storage |
Pragma_Test_Case |
Pragma_Thread_Local_Storage |
Pragma_Time_Slice |
Pragma_Title |
Pragma_Type_Invariant |
Pragma_Type_Invariant_Class |
Pragma_Unchecked_Union |
Pragma_Unevaluated_Use_Of_Old |
Pragma_Unimplemented_Unit |
Pragma_Universal_Aliasing |
Pragma_Universal_Data |
Pragma_Unmodified |
Pragma_Unreferenced |
Pragma_Unreferenced_Objects |
Pragma_Unreserve_All_Interrupts |
Pragma_Unsuppress |
Pragma_Unused |
Pragma_Use_VADS_Size |
Pragma_Volatile |
Pragma_Volatile_Components |
Pragma_Volatile_Full_Access |
Pragma_Volatile_Function |
Pragma_Warning_As_Error |
Pragma_Weak_External |
Pragma_Validity_Checks =>
when Pragma_Abort_Defer
| Pragma_Abstract_State
| Pragma_Async_Readers
| Pragma_Async_Writers
| Pragma_Assertion_Policy
| Pragma_Assume
| Pragma_Assume_No_Invalid_Values
| Pragma_All_Calls_Remote
| Pragma_Allow_Integer_Address
| Pragma_Annotate
| Pragma_Assert
| Pragma_Assert_And_Cut
| Pragma_Asynchronous
| Pragma_Atomic
| Pragma_Atomic_Components
| Pragma_Attach_Handler
| Pragma_Attribute_Definition
| Pragma_Check
| Pragma_Check_Float_Overflow
| Pragma_Check_Name
| Pragma_Check_Policy
| Pragma_Compile_Time_Error
| Pragma_Compile_Time_Warning
| Pragma_Constant_After_Elaboration
| Pragma_Contract_Cases
| Pragma_Convention_Identifier
| Pragma_CPP_Class
| Pragma_CPP_Constructor
| Pragma_CPP_Virtual
| Pragma_CPP_Vtable
| Pragma_CPU
| Pragma_C_Pass_By_Copy
| Pragma_Comment
| Pragma_Common_Object
| Pragma_Complete_Representation
| Pragma_Complex_Representation
| Pragma_Component_Alignment
| Pragma_Controlled
| Pragma_Convention
| Pragma_Debug_Policy
| Pragma_Depends
| Pragma_Detect_Blocking
| Pragma_Default_Initial_Condition
| Pragma_Default_Scalar_Storage_Order
| Pragma_Default_Storage_Pool
| Pragma_Disable_Atomic_Synchronization
| Pragma_Discard_Names
| Pragma_Dispatching_Domain
| Pragma_Effective_Reads
| Pragma_Effective_Writes
| Pragma_Eliminate
| Pragma_Elaborate
| Pragma_Elaborate_All
| Pragma_Elaborate_Body
| Pragma_Elaboration_Checks
| Pragma_Enable_Atomic_Synchronization
| Pragma_Export
| Pragma_Export_Function
| Pragma_Export_Object
| Pragma_Export_Procedure
| Pragma_Export_Value
| Pragma_Export_Valued_Procedure
| Pragma_Extend_System
| Pragma_Extensions_Visible
| Pragma_External
| Pragma_External_Name_Casing
| Pragma_Favor_Top_Level
| Pragma_Fast_Math
| Pragma_Finalize_Storage_Only
| Pragma_Ghost
| Pragma_Global
| Pragma_Ident
| Pragma_Implementation_Defined
| Pragma_Implemented
| Pragma_Implicit_Packing
| Pragma_Import
| Pragma_Import_Function
| Pragma_Import_Object
| Pragma_Import_Procedure
| Pragma_Import_Valued_Procedure
| Pragma_Independent
| Pragma_Independent_Components
| Pragma_Initial_Condition
| Pragma_Initialize_Scalars
| Pragma_Initializes
| Pragma_Inline
| Pragma_Inline_Always
| Pragma_Inline_Generic
| Pragma_Inspection_Point
| Pragma_Interface
| Pragma_Interface_Name
| Pragma_Interrupt_Handler
| Pragma_Interrupt_State
| Pragma_Interrupt_Priority
| Pragma_Invariant
| Pragma_Keep_Names
| Pragma_License
| Pragma_Link_With
| Pragma_Linker_Alias
| Pragma_Linker_Constructor
| Pragma_Linker_Destructor
| Pragma_Linker_Options
| Pragma_Linker_Section
| Pragma_Lock_Free
| Pragma_Locking_Policy
| Pragma_Loop_Invariant
| Pragma_Loop_Optimize
| Pragma_Loop_Variant
| Pragma_Machine_Attribute
| Pragma_Main
| Pragma_Main_Storage
| Pragma_Max_Queue_Length
| Pragma_Memory_Size
| Pragma_No_Body
| Pragma_No_Elaboration_Code_All
| Pragma_No_Inline
| Pragma_No_Return
| Pragma_No_Run_Time
| Pragma_No_Strict_Aliasing
| Pragma_No_Tagged_Streams
| Pragma_Normalize_Scalars
| Pragma_Obsolescent
| Pragma_Ordered
| Pragma_Optimize
| Pragma_Optimize_Alignment
| Pragma_Overflow_Mode
| Pragma_Overriding_Renamings
| Pragma_Pack
| Pragma_Part_Of
| Pragma_Partition_Elaboration_Policy
| Pragma_Passive
| Pragma_Preelaborable_Initialization
| Pragma_Polling
| Pragma_Prefix_Exception_Messages
| Pragma_Persistent_BSS
| Pragma_Post
| Pragma_Postcondition
| Pragma_Post_Class
| Pragma_Pre
| Pragma_Precondition
| Pragma_Predicate
| Pragma_Predicate_Failure
| Pragma_Preelaborate
| Pragma_Pre_Class
| Pragma_Priority
| Pragma_Priority_Specific_Dispatching
| Pragma_Profile
| Pragma_Profile_Warnings
| Pragma_Propagate_Exceptions
| Pragma_Provide_Shift_Operators
| Pragma_Psect_Object
| Pragma_Pure
| Pragma_Pure_Function
| Pragma_Queuing_Policy
| Pragma_Refined_Depends
| Pragma_Refined_Global
| Pragma_Refined_Post
| Pragma_Refined_State
| Pragma_Relative_Deadline
| Pragma_Remote_Access_Type
| Pragma_Remote_Call_Interface
| Pragma_Remote_Types
| Pragma_Restricted_Run_Time
| Pragma_Rational
| Pragma_Ravenscar
| Pragma_Rename_Pragma
| Pragma_Reviewable
| Pragma_Secondary_Stack_Size
| Pragma_Share_Generic
| Pragma_Shared
| Pragma_Shared_Passive
| Pragma_Short_Circuit_And_Or
| Pragma_Short_Descriptors
| Pragma_Simple_Storage_Pool_Type
| Pragma_SPARK_Mode
| Pragma_Storage_Size
| Pragma_Storage_Unit
| Pragma_Static_Elaboration_Desired
| Pragma_Stream_Convert
| Pragma_Subtitle
| Pragma_Suppress
| Pragma_Suppress_Debug_Info
| Pragma_Suppress_Exception_Locations
| Pragma_Suppress_Initialization
| Pragma_System_Name
| Pragma_Task_Dispatching_Policy
| Pragma_Task_Info
| Pragma_Task_Name
| Pragma_Task_Storage
| Pragma_Test_Case
| Pragma_Thread_Local_Storage
| Pragma_Time_Slice
| Pragma_Title
| Pragma_Type_Invariant
| Pragma_Type_Invariant_Class
| Pragma_Unchecked_Union
| Pragma_Unevaluated_Use_Of_Old
| Pragma_Unimplemented_Unit
| Pragma_Universal_Aliasing
| Pragma_Universal_Data
| Pragma_Unmodified
| Pragma_Unreferenced
| Pragma_Unreferenced_Objects
| Pragma_Unreserve_All_Interrupts
| Pragma_Unsuppress
| Pragma_Unused
| Pragma_Use_VADS_Size
| Pragma_Volatile
| Pragma_Volatile_Components
| Pragma_Volatile_Full_Access
| Pragma_Volatile_Function
| Pragma_Warning_As_Error
| Pragma_Weak_External
| Pragma_Validity_Checks
=>
null;
--------------------

163
gcc/ada/par_sco.adb

@ -756,7 +756,12 @@ package body Par_SCO is
-- Logical operators, output table entries and then process
-- operands recursively to deal with nested conditions.
when N_And_Then | N_Or_Else | N_Op_Not | N_Op_And | N_Op_Or =>
when N_And_Then
| N_Op_And
| N_Op_Not
| N_Op_Or
| N_Or_Else
=>
declare
T : Character;
@ -828,7 +833,6 @@ package body Par_SCO is
when others =>
return OK;
end case;
end Process_Node;
@ -1131,21 +1135,21 @@ package body Par_SCO is
Traverse_Aux_Decls (Cunit (U));
case Nkind (Lu) is
when N_Generic_Instantiation |
N_Generic_Package_Declaration |
N_Package_Body |
N_Package_Declaration |
N_Protected_Body |
N_Subprogram_Body |
N_Subprogram_Declaration |
N_Task_Body =>
when N_Generic_Instantiation
| N_Generic_Package_Declaration
| N_Package_Body
| N_Package_Declaration
| N_Protected_Body
| N_Subprogram_Body
| N_Subprogram_Declaration
| N_Task_Body
=>
Traverse_Declarations_Or_Statements (L => No_List, P => Lu);
-- All other cases of compilation units (e.g. renamings), generate no
-- SCO information.
when others =>
-- All other cases of compilation units (e.g. renamings), generate
-- no SCO information.
null;
end case;
@ -1477,7 +1481,9 @@ package body Par_SCO is
when N_Case_Statement =>
To_Node := Expression (N);
when N_If_Statement | N_Elsif_Part =>
when N_Elsif_Part
| N_If_Statement
=>
To_Node := Condition (N);
when N_Extended_Return_Statement =>
@ -1486,15 +1492,18 @@ package body Par_SCO is
when N_Loop_Statement =>
To_Node := Iteration_Scheme (N);
when N_Asynchronous_Select |
N_Conditional_Entry_Call |
N_Selective_Accept |
N_Single_Protected_Declaration |
N_Single_Task_Declaration |
N_Timed_Entry_Call =>
when N_Asynchronous_Select
| N_Conditional_Entry_Call
| N_Selective_Accept
| N_Single_Protected_Declaration
| N_Single_Task_Declaration
| N_Timed_Entry_Call
=>
T := F;
when N_Protected_Type_Declaration | N_Task_Type_Declaration =>
when N_Protected_Type_Declaration
| N_Task_Type_Declaration
=>
if Has_Aspects (N) then
To_Node := Last (Aspect_Specifications (N));
@ -1507,7 +1516,6 @@ package body Par_SCO is
when others =>
null;
end case;
if Present (To_Node) then
@ -1662,12 +1670,13 @@ package body Par_SCO is
-- specification. The corresponding pragma will have the same
-- sloc.
when Aspect_Invariant |
Aspect_Post |
Aspect_Postcondition |
Aspect_Pre |
Aspect_Precondition |
Aspect_Type_Invariant =>
when Aspect_Invariant
| Aspect_Post
| Aspect_Postcondition
| Aspect_Pre
| Aspect_Precondition
| Aspect_Type_Invariant
=>
C1 := 'a';
-- Aspects whose checks are generated in client units,
@ -1680,9 +1689,10 @@ package body Par_SCO is
-- Pre/post can have checks in client units too because of
-- inheritance, so should they be moved here???
when Aspect_Dynamic_Predicate |
Aspect_Predicate |
Aspect_Static_Predicate =>
when Aspect_Dynamic_Predicate
| Aspect_Predicate
| Aspect_Static_Predicate
=>
C1 := 'A';
-- Other aspects: just process any decision nested in the
@ -1692,7 +1702,6 @@ package body Par_SCO is
if Has_Decision (AE) then
C1 := 'X';
end if;
end case;
if C1 /= ASCII.NUL then
@ -1744,7 +1753,9 @@ package body Par_SCO is
-- Subprogram declaration or subprogram body stub
when N_Subprogram_Declaration | N_Subprogram_Body_Stub =>
when N_Subprogram_Body_Stub
| N_Subprogram_Declaration
=>
Process_Decisions_Defer
(Parameter_Specifications (Specification (N)), 'X');
@ -1763,7 +1774,9 @@ package body Par_SCO is
-- Task or subprogram body
when N_Task_Body | N_Subprogram_Body =>
when N_Subprogram_Body
| N_Task_Body
=>
Set_Statement_Entry;
Traverse_Subprogram_Or_Task_Body (N);
@ -1980,7 +1993,9 @@ package body Par_SCO is
(L => Else_Statements (N),
D => Current_Dominant);
when N_Timed_Entry_Call | N_Conditional_Entry_Call =>
when N_Conditional_Entry_Call
| N_Timed_Entry_Call
=>
Extend_Statement_Sequence (N, 'S');
Set_Statement_Entry;
@ -2042,9 +2057,10 @@ package body Par_SCO is
-- Unconditional exit points, which are included in the current
-- statement sequence, but then terminate it
when N_Requeue_Statement |
N_Goto_Statement |
N_Raise_Statement =>
when N_Goto_Statement
| N_Raise_Statement
| N_Requeue_Statement
=>
Extend_Statement_Sequence (N, ' ');
Set_Statement_Entry;
Current_Dominant := No_Dominant;
@ -2139,14 +2155,14 @@ package body Par_SCO is
begin
case Nam is
when Name_Assert |
Name_Assert_And_Cut |
Name_Assume |
Name_Check |
Name_Loop_Invariant |
Name_Postcondition |
Name_Precondition =>
when Name_Assert
| Name_Assert_And_Cut
| Name_Assume
| Name_Check
| Name_Loop_Invariant
| Name_Postcondition
| Name_Precondition
=>
-- For Assert/Check/Precondition/Postcondition, we
-- must generate a P entry for the decision. Note
-- that this is done unconditionally at this stage.
@ -2204,7 +2220,9 @@ package body Par_SCO is
-- want one entry in the SCOs, so we take the first, for which
-- Prev_Ids is False.
when N_Object_Declaration | N_Number_Declaration =>
when N_Number_Declaration
| N_Object_Declaration
=>
if not Prev_Ids (N) then
Extend_Statement_Sequence (N, 'o');
@ -2216,14 +2234,18 @@ package body Par_SCO is
-- All other cases, which extend the current statement sequence
-- but do not terminate it, even if they have nested decisions.
when N_Protected_Type_Declaration | N_Task_Type_Declaration =>
when N_Protected_Type_Declaration
| N_Task_Type_Declaration
=>
Extend_Statement_Sequence (N, 't');
Process_Decisions_Defer (Discriminant_Specifications (N), 'X');
Set_Statement_Entry;
Traverse_Sync_Definition (N);
when N_Single_Protected_Declaration | N_Single_Task_Declaration =>
when N_Single_Protected_Declaration
| N_Single_Task_Declaration
=>
Extend_Statement_Sequence (N, 'o');
Set_Statement_Entry;
@ -2240,33 +2262,35 @@ package body Par_SCO is
begin
case NK is
when N_Full_Type_Declaration |
N_Incomplete_Type_Declaration |
N_Private_Extension_Declaration |
N_Private_Type_Declaration =>
when N_Full_Type_Declaration
| N_Incomplete_Type_Declaration
| N_Private_Extension_Declaration
| N_Private_Type_Declaration
=>
Typ := 't';
when N_Subtype_Declaration =>
when N_Subtype_Declaration =>
Typ := 's';
when N_Renaming_Declaration =>
when N_Renaming_Declaration =>
Typ := 'r';
when N_Generic_Instantiation =>
when N_Generic_Instantiation =>
Typ := 'i';
when N_Package_Body_Stub |
N_Protected_Body_Stub |
N_Representation_Clause |
N_Task_Body_Stub |
N_Use_Package_Clause |
N_Use_Type_Clause =>
when N_Package_Body_Stub
| N_Protected_Body_Stub
| N_Representation_Clause
| N_Task_Body_Stub
| N_Use_Package_Clause
| N_Use_Type_Clause
=>
Typ := ASCII.NUL;
when N_Procedure_Call_Statement =>
Typ := ' ';
when others =>
when others =>
if NK in N_Statement_Other_Than_Procedure_Call then
Typ := ' ';
else
@ -2421,12 +2445,14 @@ package body Par_SCO is
begin
case Nkind (N) is
when N_Protected_Type_Declaration |
N_Single_Protected_Declaration =>
when N_Protected_Type_Declaration
| N_Single_Protected_Declaration
=>
Sync_Def := Protected_Definition (N);
when N_Single_Task_Declaration |
N_Task_Type_Declaration =>
when N_Single_Task_Declaration
| N_Task_Type_Declaration
=>
Sync_Def := Task_Definition (N);
when others =>
@ -2724,7 +2750,6 @@ package body Par_SCO is
-- operator.
return T.C2 /= '?';
end case;
end;
end loop;

112
gcc/ada/pprint.adb

@ -205,7 +205,9 @@ package body Pprint is
end if;
case Nkind (Expr) is
when N_Defining_Identifier | N_Identifier =>
when N_Defining_Identifier
| N_Identifier
=>
return Ident_Image (Expr, Expression_Image.Expr, Expand_Type);
when N_Character_Literal =>
@ -340,7 +342,9 @@ package body Pprint is
return ".all";
end if;
when N_Expanded_Name | N_Selected_Component =>
when N_Expanded_Name
| N_Selected_Component
=>
if Take_Prefix then
return
Expr_Name (Prefix (Expr)) & "." &
@ -381,7 +385,9 @@ package body Pprint is
end if;
end;
when N_Unchecked_Expression | N_Expression_With_Actions =>
when N_Expression_With_Actions
| N_Unchecked_Expression
=>
return Expr_Name (Expression (Expr));
when N_Raise_Constraint_Error =>
@ -623,24 +629,27 @@ package body Pprint is
loop
case Nkind (Left) is
when N_And_Then |
N_Binary_Op |
N_Membership_Test |
N_Or_Else =>
when N_And_Then
| N_Binary_Op
| N_Membership_Test
| N_Or_Else
=>
Left := Original_Node (Left_Opnd (Left));
when N_Attribute_Reference |
N_Expanded_Name |
N_Explicit_Dereference |
N_Indexed_Component |
N_Reference |
N_Selected_Component |
N_Slice =>
when N_Attribute_Reference
| N_Expanded_Name
| N_Explicit_Dereference
| N_Indexed_Component
| N_Reference
| N_Selected_Component
| N_Slice
=>
Left := Original_Node (Prefix (Left));
when N_Defining_Program_Unit_Name |
N_Designator |
N_Function_Call =>
when N_Defining_Program_Unit_Name
| N_Designator
| N_Function_Call
=>
Left := Original_Node (Name (Left));
when N_Range =>
@ -658,14 +667,16 @@ package body Pprint is
loop
case Nkind (Right) is
when N_And_Then |
N_Membership_Test |
N_Op |
N_Or_Else =>
when N_And_Then
| N_Membership_Test
| N_Op
| N_Or_Else
=>
Right := Original_Node (Right_Opnd (Right));
when N_Expanded_Name |
N_Selected_Component =>
when N_Expanded_Name
| N_Selected_Component
=>
Right := Original_Node (Selector_Name (Right));
when N_Designator =>
@ -749,33 +760,38 @@ package body Pprint is
if Right /= Expr then
while Scn < End_Sloc loop
case Src (Scn) is
when ' ' | ASCII.HT =>
if not Skipping_Comment and then not Underscore then
Underscore := True;
Index := Index + 1;
Buffer (Index) := ' ';
end if;
-- CR/LF/FF is the end of any comment
when ASCII.LF | ASCII.CR | ASCII.FF =>
Skipping_Comment := False;
when others =>
Underscore := False;
if not Skipping_Comment then
-- Ignore comment
if Src (Scn) = '-' and then Src (Scn + 1) = '-' then
Skipping_Comment := True;
else
when ' '
| ASCII.HT
=>
if not Skipping_Comment and then not Underscore then
Underscore := True;
Index := Index + 1;
Buffer (Index) := Src (Scn);
Buffer (Index) := ' ';
end if;
-- CR/LF/FF is the end of any comment
when ASCII.CR
| ASCII.FF
| ASCII.LF
=>
Skipping_Comment := False;
when others =>
Underscore := False;
if not Skipping_Comment then
-- Ignore comment
if Src (Scn) = '-' and then Src (Scn + 1) = '-' then
Skipping_Comment := True;
else
Index := Index + 1;
Buffer (Index) := Src (Scn);
end if;
end if;
end if;
end case;
Scn := Scn + 1;

21
gcc/ada/prep.adb

@ -211,8 +211,14 @@ package body Prep is
begin
if New_Name /= No_Name then
case Token is
when Tok_If | Tok_Else | Tok_Elsif | Tok_End |
Tok_And | Tok_Or | Tok_Then =>
when Tok_And
| Tok_Else
| Tok_Elsif
| Tok_End
| Tok_If
| Tok_Or
| Tok_Then
=>
if All_Keywords then
Token := Tok_Identifier;
Token_Name := New_Name;
@ -458,12 +464,11 @@ package body Prep is
-- Handle relational operator
elsif
Token = Tok_Equal or else
Token = Tok_Less or else
Token = Tok_Less_Equal or else
Token = Tok_Greater or else
Token = Tok_Greater_Equal
elsif Token = Tok_Equal
or else Token = Tok_Less
or else Token = Tok_Less_Equal
or else Token = Tok_Greater
or else Token = Tok_Greater_Equal
then
Relop := Token;
Scan.all;

73
gcc/ada/prj-dect.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2016, 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- --
@ -245,7 +245,9 @@ package body Prj.Dect is
begin
case Qualif is
when Aggregate | Aggregate_Library =>
when Aggregate
| Aggregate_Library
=>
if Name = Snames.Name_Languages
or else Name = Snames.Name_Source_Files
or else Name = Snames.Name_Source_List_File
@ -449,38 +451,39 @@ package body Prj.Dect is
if Token = Tok_At then
case Attribute_Kind_Of (Current_Attribute) is
when Optional_Index_Associative_Array |
Optional_Index_Case_Insensitive_Associative_Array =>
Scan (In_Tree);
Expect (Tok_Integer_Literal, "integer literal");
if Token = Tok_Integer_Literal then
-- Set the source index value from given literal
declare
Index : constant Int :=
UI_To_Int (Int_Literal_Value);
begin
if Index = 0 then
Error_Msg
(Flags, "index cannot be zero", Token_Ptr);
else
Set_Source_Index_Of
(Attribute, In_Tree, To => Index);
end if;
end;
when Optional_Index_Associative_Array
| Optional_Index_Case_Insensitive_Associative_Array
=>
Scan (In_Tree);
end if;
Expect (Tok_Integer_Literal, "integer literal");
when others =>
Error_Msg (Flags, "index not allowed here", Token_Ptr);
Scan (In_Tree);
if Token = Tok_Integer_Literal then
if Token = Tok_Integer_Literal then
-- Set the source index value from given literal
declare
Index : constant Int :=
UI_To_Int (Int_Literal_Value);
begin
if Index = 0 then
Error_Msg
(Flags, "index cannot be zero", Token_Ptr);
else
Set_Source_Index_Of
(Attribute, In_Tree, To => Index);
end if;
end;
Scan (In_Tree);
end if;
when others =>
Error_Msg (Flags, "index not allowed here", Token_Ptr);
Scan (In_Tree);
end if;
if Token = Tok_Integer_Literal then
Scan (In_Tree);
end if;
end case;
end if;
end if;
@ -1022,7 +1025,7 @@ package body Prj.Dect is
while Present (The_Variable)
and then Name_Of (The_Variable, In_Tree) /=
Token_Name
Token_Name
loop
The_Variable := Next_Variable (The_Variable, In_Tree);
end loop;
@ -1032,10 +1035,8 @@ package body Prj.Dect is
if No (The_Variable) then
Error_Msg
(Flags,
"a variable cannot be declared " &
"for the first time here",
Token_Ptr);
(Flags, "a variable cannot be declared for the "
& "first time here", Token_Ptr);
end if;
end;
end if;
@ -1051,7 +1052,6 @@ package body Prj.Dect is
Set_Previous_Line_Node (Current_Declaration);
when Tok_For =>
Parse_Attribute_Declaration
(In_Tree => In_Tree,
Attribute => Current_Declaration,
@ -1065,7 +1065,6 @@ package body Prj.Dect is
Set_Previous_Line_Node (Current_Declaration);
when Tok_Null =>
Scan (In_Tree); -- past "null"
when Tok_Package =>

7
gcc/ada/prj-env.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2016, 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- --
@ -887,7 +887,10 @@ package body Prj.Env is
when Spec =>
Suffix :=
Source.Language.Config.Mapping_Spec_Suffix;
when Impl | Sep =>
when Impl
| Sep
=>
Suffix :=
Source.Language.Config.Mapping_Body_Suffix;
end case;

49
gcc/ada/prj-nmsc.adb

@ -1501,9 +1501,9 @@ package body Prj.Nmsc is
Lang_Index.Config.Compiler_Driver :=
File_Name_Type (Element.Value.Value);
when Name_Required_Switches
| Name_Leading_Required_Switches
=>
when Name_Leading_Required_Switches
| Name_Required_Switches
=>
Put (Into_List =>
Lang_Index.Config.
Compiler_Leading_Required_Switches,
@ -1808,8 +1808,9 @@ package body Prj.Nmsc is
and then Element.Value.Value /= No_Name
then
case Current_Array.Name is
when Name_Spec_Suffix | Name_Specification_Suffix =>
when Name_Spec_Suffix
| Name_Specification_Suffix
=>
-- Attribute Spec_Suffix (<language>)
Get_Name_String (Element.Value.Value);
@ -1818,8 +1819,9 @@ package body Prj.Nmsc is
Lang_Index.Config.Naming_Data.Spec_Suffix :=
Name_Find;
when Name_Implementation_Suffix | Name_Body_Suffix =>
when Name_Body_Suffix
| Name_Implementation_Suffix
=>
Get_Name_String (Element.Value.Value);
Canonical_Case_File_Name
(Name_Buffer (1 .. Name_Len));
@ -2513,6 +2515,7 @@ package body Prj.Nmsc is
& """ for Objects_Linked",
Element.Value.Location, Project);
end;
when others =>
null;
end case;
@ -3448,7 +3451,9 @@ package body Prj.Nmsc is
Lib_Name.Location, Project);
end if;
when Library | Aggregate_Library =>
when Aggregate_Library
| Library
=>
if not Project.Library then
if Project.Library_Name = No_Name then
Error_Msg
@ -4043,7 +4048,9 @@ package body Prj.Nmsc is
begin
case Kind is
when Impl | Sep =>
when Impl
| Sep
=>
Exceptions :=
Value_Of
(Name_Implementation_Exceptions,
@ -4139,7 +4146,9 @@ package body Prj.Nmsc is
begin
case Kind is
when Impl | Sep =>
when Impl
| Sep
=>
Exceptions :=
Value_Of
(Name_Body,
@ -4403,11 +4412,11 @@ package body Prj.Nmsc is
Lang_Id := Project.Languages;
while Lang_Id /= No_Language_Index loop
case Lang_Id.Config.Kind is
when File_Based =>
Process_Exceptions_File_Based (Lang_Id, Kind);
when File_Based =>
Process_Exceptions_File_Based (Lang_Id, Kind);
when Unit_Based =>
Process_Exceptions_Unit_Based (Lang_Id, Kind);
when Unit_Based =>
Process_Exceptions_Unit_Based (Lang_Id, Kind);
end case;
Lang_Id := Lang_Id.Next;
@ -6001,7 +6010,9 @@ package body Prj.Nmsc is
end if;
end loop;
when Mixed_Case | Unknown =>
when Mixed_Case
| Unknown
=>
null;
end case;
end if;
@ -8412,11 +8423,13 @@ package body Prj.Nmsc is
when Silent =>
null;
when Warning | Error =>
when Error
| Warning
=>
declare
Msg : constant String :=
"<there are no "
& Lang_Name & " sources in this project";
"<there are no " & Lang_Name
& " sources in this project";
begin
Error_Msg_Warn := Data.Flags.When_No_Sources = Warning;

13
gcc/ada/prj-pp.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2016, 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- --
@ -393,16 +393,21 @@ package body Prj.PP is
Start_Line (Indent);
case Project_Qualifier_Of (Node, In_Tree) is
when Unspecified | Standard =>
when Standard
| Unspecified
=>
null;
when Aggregate =>
when Aggregate =>
Write_String ("aggregate ", Indent);
when Aggregate_Library =>
Write_String ("aggregate library ", Indent);
when Library =>
when Library =>
Write_String ("library ", Indent);
when Configuration =>
Write_String ("configuration ", Indent);
when Abstract_Project =>
Write_String ("abstract ", Indent);
end case;

31
gcc/ada/prj-proc.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2016, 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- --
@ -547,7 +547,6 @@ package body Prj.Proc is
Kind_Of (The_Current_Term, From_Project_Node_Tree);
case Current_Term_Kind is
when N_Literal_String =>
case Kind is
when Undefined =>
@ -566,7 +565,6 @@ package body Prj.Proc is
(The_Current_Term, From_Project_Node_Tree);
when List =>
String_Element_Table.Increment_Last
(Shared.String_Elements);
@ -695,7 +693,9 @@ package body Prj.Proc is
end if;
end;
when N_Variable_Reference | N_Attribute_Reference =>
when N_Attribute_Reference
| N_Variable_Reference
=>
declare
The_Project : Project_Id := Project;
The_Package : Package_Id := Pkg;
@ -981,16 +981,17 @@ package body Prj.Proc is
when Read_Only_Value =>
null;
when Empty_Value =>
when Empty_Value =>
The_Variable.Values := Nil_String;
when Dot_Value =>
when Dot_Value =>
The_Variable.Values :=
Shared.Dot_String_List;
when Object_Dir_Value |
Target_Value |
Runtime_Value =>
when Object_Dir_Value
| Runtime_Value
| Target_Value
=>
null;
end case;
end case;
@ -1008,7 +1009,6 @@ package body Prj.Proc is
when Single =>
case The_Variable.Kind is
when Undefined =>
null;
@ -1028,7 +1028,6 @@ package body Prj.Proc is
when List =>
case The_Variable.Kind is
when Undefined =>
null;
@ -1066,7 +1065,6 @@ package body Prj.Proc is
Index => 0);
when List =>
declare
The_List : String_List_Id :=
The_Variable.Values;
@ -1283,7 +1281,6 @@ package body Prj.Proc is
end if;
case Kind is
when Undefined =>
null;
@ -1365,7 +1362,6 @@ package body Prj.Proc is
(False,
"illegal node kind in an expression");
raise Program_Error;
end case;
end if;
@ -2465,9 +2461,10 @@ package body Prj.Proc is
when N_String_Type_Declaration =>
null;
when N_Attribute_Declaration |
N_Typed_Variable_Declaration |
N_Variable_Declaration =>
when N_Attribute_Declaration
| N_Typed_Variable_Declaration
| N_Variable_Declaration
=>
Process_Attribute_Declaration (Current);
when N_Case_Construction =>

6
gcc/ada/prj-strt.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2016, 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- --
@ -1556,7 +1556,9 @@ package body Prj.Strt is
end if;
end if;
when Tok_External | Tok_External_As_List =>
when Tok_External
| Tok_External_As_List
=>
External_Reference
(In_Tree => In_Tree,
Flags => Flags,

6
gcc/ada/prj-tree.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2016, 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- --
@ -1743,8 +1743,8 @@ package body Prj.Tree is
-- comment zone with the node of the preceding line (either
-- a Previous_Line or a Previous_End node), if any.
if Comments.Last > 0 and then
not Comments.Table (1).Follows_Empty_Line
if Comments.Last > 0
and then not Comments.Table (1).Follows_Empty_Line
then
if Present (Previous_Line_Node) then
Add_Comments

17
gcc/ada/prj.adb

@ -306,7 +306,9 @@ package body Prj is
when Makefile =>
return Extend_Name (Source_File_Name, Makefile_Dependency_Suffix);
when ALI_File | ALI_Closure =>
when ALI_Closure
| ALI_File
=>
return Extend_Name (Source_File_Name, ALI_Dependency_Suffix);
end case;
end Dependency_Name;
@ -1250,7 +1252,9 @@ package body Prj is
Free_List (Project.Languages);
case Project.Qualifier is
when Aggregate | Aggregate_Library =>
when Aggregate
| Aggregate_Library
=>
Free (Project.Aggregated_Projects);
when others =>
@ -1899,12 +1903,9 @@ package body Prj is
begin
if Source.Unit /= No_Unit_Index then
case Source.Kind is
when Impl =>
return Source.Unit.File_Names (Spec);
when Spec =>
return Source.Unit.File_Names (Impl);
when Sep =>
return No_Source;
when Impl => return Source.Unit.File_Names (Spec);
when Spec => return Source.Unit.File_Names (Impl);
when Sep => return No_Source;
end case;
else
return No_Source;

42
gcc/ada/repinfo.adb

@ -643,7 +643,6 @@ package body Repinfo is
when Discrim_Val =>
Write_Char ('#');
UI_Write (Node.Op1);
end case;
end;
end if;
@ -711,7 +710,9 @@ package body Repinfo is
when E_Subprogram_Type =>
Write_Str ("type ");
when E_Entry | E_Entry_Family =>
when E_Entry
| E_Entry_Family
=>
Write_Str ("entry ");
when others =>
@ -727,31 +728,43 @@ package body Repinfo is
Write_Str (" convention : ");
case Convention (Ent) is
when Convention_Ada =>
when Convention_Ada =>
Write_Line ("Ada");
when Convention_Ada_Pass_By_Copy =>
when Convention_Ada_Pass_By_Copy =>
Write_Line ("Ada_Pass_By_Copy");
when Convention_Ada_Pass_By_Reference =>
Write_Line ("Ada_Pass_By_Reference");
when Convention_Intrinsic =>
when Convention_Intrinsic =>
Write_Line ("Intrinsic");
when Convention_Entry =>
when Convention_Entry =>
Write_Line ("Entry");
when Convention_Protected =>
when Convention_Protected =>
Write_Line ("Protected");
when Convention_Assembler =>
when Convention_Assembler =>
Write_Line ("Assembler");
when Convention_C =>
when Convention_C =>
Write_Line ("C");
when Convention_COBOL =>
when Convention_COBOL =>
Write_Line ("COBOL");
when Convention_CPP =>
when Convention_CPP =>
Write_Line ("C++");
when Convention_Fortran =>
when Convention_Fortran =>
Write_Line ("Fortran");
when Convention_Stdcall =>
when Convention_Stdcall =>
Write_Line ("Stdcall");
when Convention_Stubbed =>
when Convention_Stubbed =>
Write_Line ("Stubbed");
end case;
@ -1435,7 +1448,6 @@ package body Repinfo is
pragma Assert (Sub in D'Range);
return D (Sub);
end;
end case;
end;
end if;

5
gcc/ada/rtsfind.adb

@ -33,6 +33,7 @@ with Errout; use Errout;
with Exp_Dist; use Exp_Dist;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
with Ghost; use Ghost;
with Lib; use Lib;
with Lib.Load; use Lib.Load;
with Namet; use Namet;
@ -938,7 +939,7 @@ package body Rtsfind is
-- Provide a clean environment for the unit
Ghost_Mode := None;
Install_Ghost_Mode (None);
-- Note if secondary stack is used
@ -1041,7 +1042,7 @@ package body Rtsfind is
Set_Is_Potentially_Use_Visible (U.Entity, True);
end if;
Ghost_Mode := Save_Ghost_Mode;
Restore_Ghost_Mode (Save_Ghost_Mode);
end Load_RTU;
--------------------

4
gcc/ada/s-exctra.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2000-2015, AdaCore --
-- Copyright (C) 2000-2016, AdaCore --
-- --
-- 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- --
@ -112,8 +112,10 @@ package body System.Exception_Traces is
case Kind is
when Every_Raise =>
Exception_Trace := Every_Raise;
when Unhandled_Raise =>
Exception_Trace := Unhandled_Raise;
when Unhandled_Raise_In_Main =>
Exception_Trace := Unhandled_Raise_In_Main;
end case;

6
gcc/ada/s-fileio.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
@ -500,7 +500,9 @@ package body System.File_IO is
Fptr := 2;
end if;
when Inout_File | Append_File =>
when Append_File
| Inout_File
=>
Fopstr (1) := (if Creat then 'w' else 'r');
Fopstr (2) := '+';
Fptr := 3;

10
gcc/ada/s-interr.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -761,8 +761,8 @@ package body System.Interrupts is
Server := Server_ID (Interrupt);
case Server.Common.State is
when Interrupt_Server_Idle_Sleep |
Interrupt_Server_Blocked_Interrupt_Sleep
when Interrupt_Server_Blocked_Interrupt_Sleep
| Interrupt_Server_Idle_Sleep
=>
POP.Wakeup (Server, Server.Common.State);
@ -1119,8 +1119,8 @@ package body System.Interrupts is
if User_Handler (Interrupt).H /= null
or else User_Entry (Interrupt).T /= Null_Task
then
-- This is the case where the Server_Task is
-- waiting on "sigwait." Wake it up by sending an
-- This is the case where the Server_Task
-- is waiting on"sigwait." Wake it up by sending an
-- Abort_Task_Interrupt so that the Server_Task waits
-- on Cond.

16
gcc/ada/s-intman-android.adb

@ -111,21 +111,15 @@ package body System.Interrupt_Management is
pragma Unreferenced (ucontext);
begin
-- Check that treatment of exception propagation here is consistent with
-- treatment of the abort signal in System.Task_Primitives.Operations.
case signo is
when SIGFPE =>
raise Constraint_Error;
when SIGILL =>
raise Program_Error;
when SIGSEGV =>
raise Storage_Error;
when SIGBUS =>
raise Storage_Error;
when others =>
null;
when SIGFPE => raise Constraint_Error;
when SIGILL => raise Program_Error;
when SIGSEGV => raise Storage_Error;
when SIGBUS => raise Storage_Error;
when others => null;
end case;
end Map_Signal;

15
gcc/ada/s-intman-posix.adb

@ -131,16 +131,11 @@ package body System.Interrupt_Management is
-- treatment of the abort signal in System.Task_Primitives.Operations.
case signo is
when SIGFPE =>
raise Constraint_Error;
when SIGILL =>
raise Program_Error;
when SIGSEGV =>
raise Storage_Error;
when SIGBUS =>
raise Storage_Error;
when others =>
null;
when SIGFPE => raise Constraint_Error;
when SIGILL => raise Program_Error;
when SIGSEGV => raise Storage_Error;
when SIGBUS => raise Storage_Error;
when others => null;
end case;
end Notify_Exception;

21
gcc/ada/s-intman-solaris.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -92,8 +92,8 @@ package body System.Interrupt_Management is
pragma Unreferenced (info);
begin
-- Perform the necessary context adjustments prior to a raise
-- from a signal handler.
-- Perform the necessary context adjustments prior to a raise from a
-- signal handler.
Adjust_Context_For_Raise (signo, context.all'Address);
@ -101,16 +101,11 @@ package body System.Interrupt_Management is
-- treatment of the abort signal in System.Task_Primitives.Operations.
case signo is
when SIGFPE =>
raise Constraint_Error;
when SIGILL =>
raise Program_Error;
when SIGSEGV =>
raise Storage_Error;
when SIGBUS =>
raise Storage_Error;
when others =>
null;
when SIGFPE => raise Constraint_Error;
when SIGILL => raise Program_Error;
when SIGSEGV => raise Storage_Error;
when SIGBUS => raise Storage_Error;
when others => null;
end case;
end Notify_Exception;

14
gcc/ada/s-io.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
@ -59,10 +59,8 @@ package body System.IO is
begin
case Current_Out is
when Stdout =>
Put_Int (X);
when Stderr =>
Put_Int_Err (X);
when Stdout => Put_Int (X);
when Stderr => Put_Int_Err (X);
end case;
end Put;
@ -75,10 +73,8 @@ package body System.IO is
begin
case Current_Out is
when Stdout =>
Put_Char (C);
when Stderr =>
Put_Char_Stderr (C);
when Stdout => Put_Char (C);
when Stderr => Put_Char_Stderr (C);
end case;
end Put;

9
gcc/ada/s-osprim-mingw.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2015, Free Software Foundation, Inc. --
-- Copyright (C) 1998-2016, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -329,7 +329,6 @@ package body System.OS_Primitives is
-----------------
procedure Timed_Delay (Time : Duration; Mode : Integer) is
function Mode_Clock return Duration;
pragma Inline (Mode_Clock);
-- Return the current clock value using either the monotonic clock or
@ -342,10 +341,8 @@ package body System.OS_Primitives is
function Mode_Clock return Duration is
begin
case Mode is
when Absolute_RT =>
return Monotonic_Clock;
when others =>
return Clock;
when Absolute_RT => return Monotonic_Clock;
when others => return Clock;
end case;
end Mode_Clock;

8
gcc/ada/s-regexp.adb

@ -970,7 +970,10 @@ package body System.Regexp is
End_State := Current_State;
end if;
when '*' | '+' | '?' | Close_Paren | Close_Bracket =>
when Close_Bracket
| Close_Paren
| '*' | '+' | '?'
=>
Raise_Exception
("Incorrect character in regular expression :", J);
@ -1020,7 +1023,6 @@ package body System.Regexp is
End_State := Current_State;
end if;
end case;
if Start_State = 0 then
@ -1159,7 +1161,6 @@ package body System.Regexp is
J := Start_Index;
while J <= End_Index loop
case S (J) is
when Open_Bracket =>
Current_State := Current_State + 1;
@ -1344,7 +1345,6 @@ package body System.Regexp is
end if;
End_State := Current_State;
end case;
if Start_State = 0 then

37
gcc/ada/s-tasini.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -434,12 +434,15 @@ package body System.Tasking.Initialization is
begin
if not T.Aborting and then T /= Self_ID then
case T.Common.State is
when Unactivated | Terminated =>
when Terminated
| Unactivated
=>
pragma Assert (False);
null;
when Activating | Runnable =>
when Activating
| Runnable
=>
-- This is needed to cancel an asynchronous protected entry
-- call during a requeue with abort.
@ -449,15 +452,18 @@ package body System.Tasking.Initialization is
when Interrupt_Server_Blocked_On_Event_Flag =>
null;
when Delay_Sleep |
Async_Select_Sleep |
Interrupt_Server_Idle_Sleep |
Interrupt_Server_Blocked_Interrupt_Sleep |
Timer_Server_Sleep |
AST_Server_Sleep =>
when AST_Server_Sleep
| Async_Select_Sleep
| Delay_Sleep
| Interrupt_Server_Blocked_Interrupt_Sleep
| Interrupt_Server_Idle_Sleep
| Timer_Server_Sleep
=>
Wakeup (T, T.Common.State);
when Acceptor_Sleep | Acceptor_Delay_Sleep =>
when Acceptor_Delay_Sleep
| Acceptor_Sleep
=>
T.Open_Accepts := null;
Wakeup (T, T.Common.State);
@ -466,10 +472,11 @@ package body System.Tasking.Initialization is
(T.ATC_Nesting_Level).Cancellation_Attempted := True;
Wakeup (T, T.Common.State);
when Activator_Sleep |
Master_Completion_Sleep |
Master_Phase_2_Sleep |
Asynchronous_Hold =>
when Activator_Sleep
| Asynchronous_Hold
| Master_Completion_Sleep
| Master_Phase_2_Sleep
=>
null;
end case;
end if;

13
gcc/ada/s-tfsetr-default.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2009, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -81,10 +81,10 @@ procedure Send_Trace (Id : Trace_T; Info : String) is
-- We need comments here ???
case Param is
when Name_Param =>
when Name_Param =>
Match ("/N:([\w]+)", Input, Matches);
when Caller_Param =>
when Caller_Param =>
Match ("/C:([\w]+)", Input, Matches);
when Entry_Param =>
@ -96,7 +96,7 @@ procedure Send_Trace (Id : Trace_T; Info : String) is
when Acceptor_Param =>
Match ("/A:([\w]+)", Input, Matches);
when Parent_Param =>
when Parent_Param =>
Match ("/P:([\w]+)", Input, Matches);
when Number_Param =>
@ -108,7 +108,10 @@ procedure Send_Trace (Id : Trace_T; Info : String) is
end if;
case Param is
when Timeout_Param | Entry_Param | Number_Param =>
when Entry_Param
| Number_Param
| Timeout_Param
=>
return Input (Matches (2).First .. Matches (2).Last);
when others =>

3
gcc/ada/s-tfsetr-vxworks.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2009, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -98,7 +98,6 @@ begin
-- Unrecognized events are given the special Id_Event value 29999
when others => Id_Event := 29999;
end case;
Wv_Event (Id_Event, Info_Trace'Address, Max_Size);

8
gcc/ada/s-tpobop.adb

@ -671,7 +671,9 @@ package body System.Tasking.Protected_Objects.Operations is
else
case Mode is
when Simple_Call | Conditional_Call =>
when Conditional_Call
| Simple_Call
=>
if Single_Lock then
STPO.Lock_RTS;
Entry_Calls.Wait_For_Completion (Entry_Call);
@ -685,7 +687,9 @@ package body System.Tasking.Protected_Objects.Operations is
Block.Cancelled := Entry_Call.State = Cancelled;
when Asynchronous_Call | Timed_Call =>
when Asynchronous_Call
| Timed_Call
=>
pragma Assert (False);
null;
end case;

6
gcc/ada/s-tratas-default.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -62,7 +62,9 @@ package body System.Traces.Tasking is
begin
if Parameters.Runtime_Traces then
case Id is
when M_RDV_Complete | PO_Done =>
when M_RDV_Complete
| PO_Done
=>
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task_S;
Trace_S (4 + L0 .. 6 + L0) := "/C:";

5
gcc/ada/s-wchcnv.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
@ -97,7 +97,6 @@ package body System.WCh_Cnv is
begin
case EM is
when WCEM_Hex =>
if C /= ASCII.ESC then
return Character'Pos (C);
@ -245,7 +244,6 @@ package body System.WCh_Cnv is
end if;
return UTF_32_Code (B1);
end case;
end Char_Sequence_To_UTF_32;
@ -293,7 +291,6 @@ package body System.WCh_Cnv is
-- Processing depends on encoding mode
case EM is
when WCEM_Hex =>
if Val < 256 then
Out_Char (Character'Val (Val));

330
gcc/ada/scng.adb

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
@ -149,45 +149,131 @@ package body Scng is
-- Token_Type are detected by the compiler.
case Token is
when Tok_Integer_Literal | Tok_Real_Literal | Tok_String_Literal |
Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier |
Tok_Double_Asterisk | Tok_Ampersand | Tok_Minus | Tok_Plus |
Tok_Asterisk | Tok_Mod | Tok_Rem | Tok_Slash | Tok_New |
Tok_Abs | Tok_Others | Tok_Null | Tok_Dot | Tok_Apostrophe |
Tok_Left_Paren | Tok_Delta | Tok_Digits | Tok_Range |
Tok_Right_Paren | Tok_Comma | Tok_And | Tok_Or | Tok_Xor |
Tok_Less | Tok_Equal | Tok_Greater | Tok_Not_Equal |
Tok_Greater_Equal | Tok_Less_Equal | Tok_In | Tok_Not |
Tok_Box | Tok_Colon_Equal | Tok_Colon | Tok_Greater_Greater |
Tok_Abstract | Tok_Access | Tok_Aliased | Tok_All | Tok_Array |
Tok_At | Tok_Body | Tok_Constant | Tok_Do | Tok_Is |
Tok_Interface | Tok_Limited | Tok_Of | Tok_Out | Tok_Record |
Tok_Renames | Tok_Reverse =>
when Tok_Abs
| Tok_Abstract
| Tok_Access
| Tok_Aliased
| Tok_All
| Tok_Ampersand
| Tok_And
| Tok_Apostrophe
| Tok_Array
| Tok_Asterisk
| Tok_At
| Tok_Body
| Tok_Box
| Tok_Char_Literal
| Tok_Colon
| Tok_Colon_Equal
| Tok_Comma
| Tok_Constant
| Tok_Delta
| Tok_Digits
| Tok_Do
| Tok_Dot
| Tok_Double_Asterisk
| Tok_Equal
| Tok_Greater
| Tok_Greater_Equal
| Tok_Greater_Greater
| Tok_Identifier
| Tok_In
| Tok_Integer_Literal
| Tok_Interface
| Tok_Is
| Tok_Left_Paren
| Tok_Less
| Tok_Less_Equal
| Tok_Limited
| Tok_Minus
| Tok_Mod
| Tok_New
| Tok_Not
| Tok_Not_Equal
| Tok_Null
| Tok_Of
| Tok_Operator_Symbol
| Tok_Or
| Tok_Others
| Tok_Out
| Tok_Plus
| Tok_Range
| Tok_Real_Literal
| Tok_Record
| Tok_Rem
| Tok_Renames
| Tok_Reverse
| Tok_Right_Paren
| Tok_Slash
| Tok_String_Literal
| Tok_Xor
=>
System.CRC32.Update
(System.CRC32.CRC32 (Checksum),
Character'Val (Token_Type'Pos (Token)));
when Tok_Some =>
System.CRC32.Update
(System.CRC32.CRC32 (Checksum),
Character'Val (Token_Type'Pos (Tok_Identifier)));
when Tok_Tagged | Tok_Then | Tok_Less_Less | Tok_Abort | Tok_Accept |
Tok_Case | Tok_Delay | Tok_Else | Tok_Elsif | Tok_End |
Tok_Exception | Tok_Exit | Tok_Goto | Tok_If | Tok_Pragma |
Tok_Raise | Tok_Requeue | Tok_Return | Tok_Select |
Tok_Terminate | Tok_Until | Tok_When | Tok_Begin | Tok_Declare |
Tok_For | Tok_Loop | Tok_While | Tok_Entry | Tok_Protected |
Tok_Task | Tok_Type | Tok_Subtype | Tok_Overriding |
Tok_Synchronized | Tok_Use | Tok_Function | Tok_Generic |
Tok_Package | Tok_Procedure | Tok_Private | Tok_With |
Tok_Separate | Tok_EOF | Tok_Semicolon | Tok_Arrow |
Tok_Vertical_Bar | Tok_Dot_Dot | Tok_Project | Tok_Extends |
Tok_External | Tok_External_As_List | Tok_Comment |
Tok_End_Of_Line | Tok_Special | Tok_SPARK_Hide | No_Token =>
when No_Token
| Tok_Abort
| Tok_Accept
| Tok_Arrow
| Tok_Begin
| Tok_Case
| Tok_Comment
| Tok_Declare
| Tok_Delay
| Tok_Dot_Dot
| Tok_Else
| Tok_Elsif
| Tok_End
| Tok_End_Of_Line
| Tok_Entry
| Tok_EOF
| Tok_Exception
| Tok_Exit
| Tok_Extends
| Tok_External
| Tok_External_As_List
| Tok_For
| Tok_Function
| Tok_Generic
| Tok_Goto
| Tok_If
| Tok_Less_Less
| Tok_Loop
| Tok_Overriding
| Tok_Package
| Tok_Pragma
| Tok_Private
| Tok_Procedure
| Tok_Project
| Tok_Protected
| Tok_Raise
| Tok_Requeue
| Tok_Return
| Tok_Select
| Tok_Semicolon
| Tok_Separate
| Tok_SPARK_Hide
| Tok_Special
| Tok_Subtype
| Tok_Synchronized
| Tok_Tagged
| Tok_Task
| Tok_Terminate
| Tok_Then
| Tok_Type
| Tok_Until
| Tok_Use
| Tok_Vertical_Bar
| Tok_When
| Tok_While
| Tok_With
=>
System.CRC32.Update
(System.CRC32.CRC32 (Checksum),
Character'Val (Token_Type'Pos (Token_Type'Pred (Token))));
@ -205,54 +291,142 @@ package body Scng is
-- Token_Type are detected by the compiler.
case Token is
when Tok_Integer_Literal | Tok_Real_Literal | Tok_String_Literal |
Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier |
Tok_Double_Asterisk | Tok_Ampersand | Tok_Minus | Tok_Plus |
Tok_Asterisk | Tok_Mod | Tok_Rem | Tok_Slash | Tok_New |
Tok_Abs | Tok_Others | Tok_Null | Tok_Dot | Tok_Apostrophe |
Tok_Left_Paren | Tok_Delta | Tok_Digits | Tok_Range |
Tok_Right_Paren | Tok_Comma | Tok_And | Tok_Or | Tok_Xor |
Tok_Less | Tok_Equal | Tok_Greater | Tok_Not_Equal |
Tok_Greater_Equal | Tok_Less_Equal | Tok_In | Tok_Not |
Tok_Box | Tok_Colon_Equal | Tok_Colon | Tok_Greater_Greater |
Tok_Abstract | Tok_Access | Tok_Aliased | Tok_All | Tok_Array |
Tok_At | Tok_Body | Tok_Constant | Tok_Do | Tok_Is =>
when Tok_Abs
| Tok_Abstract
| Tok_Access
| Tok_Aliased
| Tok_All
| Tok_Ampersand
| Tok_And
| Tok_Apostrophe
| Tok_Array
| Tok_Asterisk
| Tok_At
| Tok_Body
| Tok_Box
| Tok_Char_Literal
| Tok_Colon
| Tok_Colon_Equal
| Tok_Comma
| Tok_Constant
| Tok_Delta
| Tok_Digits
| Tok_Do
| Tok_Dot
| Tok_Double_Asterisk
| Tok_Equal
| Tok_Greater
| Tok_Greater_Equal
| Tok_Greater_Greater
| Tok_Identifier
| Tok_In
| Tok_Integer_Literal
| Tok_Is
| Tok_Left_Paren
| Tok_Less
| Tok_Less_Equal
| Tok_Minus
| Tok_Mod
| Tok_New
| Tok_Not
| Tok_Not_Equal
| Tok_Null
| Tok_Operator_Symbol
| Tok_Or
| Tok_Others
| Tok_Plus
| Tok_Range
| Tok_Real_Literal
| Tok_Rem
| Tok_Right_Paren
| Tok_Slash
| Tok_String_Literal
| Tok_Xor
=>
System.CRC32.Update
(System.CRC32.CRC32 (Checksum),
Character'Val (Token_Type'Pos (Token)));
when Tok_Interface | Tok_Some | Tok_Overriding | Tok_Synchronized =>
when Tok_Interface
| Tok_Overriding
| Tok_Some
| Tok_Synchronized
=>
System.CRC32.Update
(System.CRC32.CRC32 (Checksum),
Character'Val (Token_Type'Pos (Tok_Identifier)));
when Tok_Limited | Tok_Of | Tok_Out | Tok_Record |
Tok_Renames | Tok_Reverse =>
when Tok_Limited
| Tok_Of
| Tok_Out
| Tok_Record
| Tok_Renames
| Tok_Reverse
=>
System.CRC32.Update
(System.CRC32.CRC32 (Checksum),
Character'Val (Token_Type'Pos (Token) - 1));
when Tok_Tagged | Tok_Then | Tok_Less_Less | Tok_Abort | Tok_Accept |
Tok_Case | Tok_Delay | Tok_Else | Tok_Elsif | Tok_End |
Tok_Exception | Tok_Exit | Tok_Goto | Tok_If | Tok_Pragma |
Tok_Raise | Tok_Requeue | Tok_Return | Tok_Select |
Tok_Terminate | Tok_Until | Tok_When | Tok_Begin | Tok_Declare |
Tok_For | Tok_Loop | Tok_While | Tok_Entry | Tok_Protected |
Tok_Task | Tok_Type | Tok_Subtype =>
when Tok_Abort
| Tok_Accept
| Tok_Begin
| Tok_Case
| Tok_Declare
| Tok_Delay
| Tok_Else
| Tok_Elsif
| Tok_End
| Tok_Entry
| Tok_Exception
| Tok_Exit
| Tok_For
| Tok_Goto
| Tok_If
| Tok_Less_Less
| Tok_Loop
| Tok_Pragma
| Tok_Protected
| Tok_Raise
| Tok_Requeue
| Tok_Return
| Tok_Select
| Tok_Subtype
| Tok_Tagged
| Tok_Task
| Tok_Terminate
| Tok_Then
| Tok_Type
| Tok_Until
| Tok_When
| Tok_While
=>
System.CRC32.Update
(System.CRC32.CRC32 (Checksum),
Character'Val (Token_Type'Pos (Token) - 2));
when Tok_Use | Tok_Function | Tok_Generic |
Tok_Package | Tok_Procedure | Tok_Private | Tok_With |
Tok_Separate | Tok_EOF | Tok_Semicolon | Tok_Arrow |
Tok_Vertical_Bar | Tok_Dot_Dot | Tok_Project | Tok_Extends |
Tok_External | Tok_External_As_List | Tok_Comment |
Tok_End_Of_Line | Tok_Special | Tok_SPARK_Hide | No_Token =>
when No_Token
| Tok_Arrow
| Tok_Comment
| Tok_Dot_Dot
| Tok_End_Of_Line
| Tok_EOF
| Tok_Extends
| Tok_External
| Tok_External_As_List
| Tok_Function
| Tok_Generic
| Tok_Package
| Tok_Private
| Tok_Procedure
| Tok_Project
| Tok_Semicolon
| Tok_Separate
| Tok_SPARK_Hide
| Tok_Special
| Tok_Use
| Tok_Vertical_Bar
| Tok_With
=>
System.CRC32.Update
(System.CRC32.CRC32 (Checksum),
Character'Val (Token_Type'Pos (Token) - 4));
@ -2217,9 +2391,32 @@ package body Scng is
-- Invalid control characters
when NUL | SOH | STX | ETX | EOT | ENQ | ACK | BEL | BS | ASCII.SO |
SI | DLE | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN |
EM | FS | GS | RS | US | DEL
when ACK
| ASCII.SO
| BEL
| BS
| CAN
| DC1
| DC2
| DC3
| DC4
| DEL
| DLE
| EM
| ENQ
| EOT
| ETB
| ETX
| FS
| GS
| NAK
| NUL
| RS
| SI
| SOH
| STX
| SYN
| US
=>
Error_Illegal_Character;
@ -2322,7 +2519,6 @@ package body Scng is
-- initial character of a wide character sequence.
<<Scan_Wide_Character>>
declare
Code : Char_Code;
Cat : Category;

152
gcc/ada/sem.adb

@ -643,9 +643,10 @@ package body Sem is
-- the call to analyze them is generated when the full list is
-- analyzed.
when N_SCIL_Dispatch_Table_Tag_Init |
N_SCIL_Dispatching_Call |
N_SCIL_Membership_Test =>
when N_SCIL_Dispatch_Table_Tag_Init
| N_SCIL_Dispatching_Call
| N_SCIL_Membership_Test
=>
null;
-- For the remaining node types, we generate compiler abort, because
@ -655,64 +656,65 @@ package body Sem is
-- node appears only in the context of a type declaration, and is
-- processed by the analyze routine for type declarations.
when N_Abortable_Part |
N_Access_Definition |
N_Access_Function_Definition |
N_Access_Procedure_Definition |
N_Access_To_Object_Definition |
N_Aspect_Specification |
N_Case_Expression_Alternative |
N_Case_Statement_Alternative |
N_Compilation_Unit_Aux |
N_Component_Association |
N_Component_Clause |
N_Component_Definition |
N_Component_List |
N_Constrained_Array_Definition |
N_Contract |
N_Decimal_Fixed_Point_Definition |
N_Defining_Character_Literal |
N_Defining_Identifier |
N_Defining_Operator_Symbol |
N_Defining_Program_Unit_Name |
N_Delta_Constraint |
N_Derived_Type_Definition |
N_Designator |
N_Digits_Constraint |
N_Discriminant_Association |
N_Discriminant_Specification |
N_Elsif_Part |
N_Entry_Call_Statement |
N_Enumeration_Type_Definition |
N_Exception_Handler |
N_Floating_Point_Definition |
N_Formal_Decimal_Fixed_Point_Definition |
N_Formal_Derived_Type_Definition |
N_Formal_Discrete_Type_Definition |
N_Formal_Floating_Point_Definition |
N_Formal_Modular_Type_Definition |
N_Formal_Ordinary_Fixed_Point_Definition |
N_Formal_Private_Type_Definition |
N_Formal_Incomplete_Type_Definition |
N_Formal_Signed_Integer_Type_Definition |
N_Function_Specification |
N_Generic_Association |
N_Index_Or_Discriminant_Constraint |
N_Iterated_Component_Association |
N_Iteration_Scheme |
N_Mod_Clause |
N_Modular_Type_Definition |
N_Ordinary_Fixed_Point_Definition |
N_Parameter_Specification |
N_Pragma_Argument_Association |
N_Procedure_Specification |
N_Real_Range_Specification |
N_Record_Definition |
N_Signed_Integer_Type_Definition |
N_Unconstrained_Array_Definition |
N_Unused_At_Start |
N_Unused_At_End |
N_Variant =>
when N_Abortable_Part
| N_Access_Definition
| N_Access_Function_Definition
| N_Access_Procedure_Definition
| N_Access_To_Object_Definition
| N_Aspect_Specification
| N_Case_Expression_Alternative
| N_Case_Statement_Alternative
| N_Compilation_Unit_Aux
| N_Component_Association
| N_Component_Clause
| N_Component_Definition
| N_Component_List
| N_Constrained_Array_Definition
| N_Contract
| N_Decimal_Fixed_Point_Definition
| N_Defining_Character_Literal
| N_Defining_Identifier
| N_Defining_Operator_Symbol
| N_Defining_Program_Unit_Name
| N_Delta_Constraint
| N_Derived_Type_Definition
| N_Designator
| N_Digits_Constraint
| N_Discriminant_Association
| N_Discriminant_Specification
| N_Elsif_Part
| N_Entry_Call_Statement
| N_Enumeration_Type_Definition
| N_Exception_Handler
| N_Floating_Point_Definition
| N_Formal_Decimal_Fixed_Point_Definition
| N_Formal_Derived_Type_Definition
| N_Formal_Discrete_Type_Definition
| N_Formal_Floating_Point_Definition
| N_Formal_Modular_Type_Definition
| N_Formal_Ordinary_Fixed_Point_Definition
| N_Formal_Private_Type_Definition
| N_Formal_Incomplete_Type_Definition
| N_Formal_Signed_Integer_Type_Definition
| N_Function_Specification
| N_Generic_Association
| N_Index_Or_Discriminant_Constraint
| N_Iterated_Component_Association
| N_Iteration_Scheme
| N_Mod_Clause
| N_Modular_Type_Definition
| N_Ordinary_Fixed_Point_Definition
| N_Parameter_Specification
| N_Pragma_Argument_Association
| N_Procedure_Specification
| N_Real_Range_Specification
| N_Record_Definition
| N_Signed_Integer_Type_Definition
| N_Unconstrained_Array_Definition
| N_Unused_At_End
| N_Unused_At_Start
| N_Variant
=>
raise Program_Error;
end case;
@ -1745,16 +1747,16 @@ package body Sem is
pragma Assert (No (CU) or else Nkind (CU) = N_Compilation_Unit);
case Nkind (Item) is
when N_Generic_Subprogram_Declaration |
N_Generic_Package_Declaration |
N_Package_Declaration |
N_Subprogram_Declaration |
N_Subprogram_Renaming_Declaration |
N_Package_Renaming_Declaration |
N_Generic_Function_Renaming_Declaration |
N_Generic_Package_Renaming_Declaration |
N_Generic_Procedure_Renaming_Declaration =>
when N_Generic_Function_Renaming_Declaration
| N_Generic_Package_Declaration
| N_Generic_Package_Renaming_Declaration
| N_Generic_Procedure_Renaming_Declaration
| N_Generic_Subprogram_Declaration
| N_Package_Declaration
| N_Package_Renaming_Declaration
| N_Subprogram_Declaration
| N_Subprogram_Renaming_Declaration
=>
-- Specs are OK
null;
@ -1774,10 +1776,10 @@ package body Sem is
or else CU = Cunit (Main_Unit));
null;
when N_Function_Instantiation |
N_Procedure_Instantiation |
N_Package_Instantiation =>
when N_Function_Instantiation
| N_Package_Instantiation
| N_Procedure_Instantiation
=>
-- Can only happen if some generic body (needed for gnat2scil
-- traversal, but not by GNAT) is not available, ignore.

5
gcc/ada/sem_aggr.adb

@ -4738,8 +4738,9 @@ package body Sem_Aggr is
when E_Array_Type =>
Comp_Typ := Component_Type (Typ);
when E_Component |
E_Discriminant =>
when E_Component
| E_Discriminant
=>
Comp_Typ := Etype (Typ);
when others =>

923
gcc/ada/sem_attr.adb

File diff suppressed because it is too large Load Diff

73
gcc/ada/sem_aux.adb

@ -438,42 +438,24 @@ package body Sem_Aux is
function Get_Binary_Nkind (Op : Entity_Id) return Node_Kind is
begin
case Chars (Op) is
when Name_Op_Add =>
return N_Op_Add;
when Name_Op_Concat =>
return N_Op_Concat;
when Name_Op_Expon =>
return N_Op_Expon;
when Name_Op_Subtract =>
return N_Op_Subtract;
when Name_Op_Mod =>
return N_Op_Mod;
when Name_Op_Multiply =>
return N_Op_Multiply;
when Name_Op_Divide =>
return N_Op_Divide;
when Name_Op_Rem =>
return N_Op_Rem;
when Name_Op_And =>
return N_Op_And;
when Name_Op_Eq =>
return N_Op_Eq;
when Name_Op_Ge =>
return N_Op_Ge;
when Name_Op_Gt =>
return N_Op_Gt;
when Name_Op_Le =>
return N_Op_Le;
when Name_Op_Lt =>
return N_Op_Lt;
when Name_Op_Ne =>
return N_Op_Ne;
when Name_Op_Or =>
return N_Op_Or;
when Name_Op_Xor =>
return N_Op_Xor;
when others =>
raise Program_Error;
when Name_Op_Add => return N_Op_Add;
when Name_Op_Concat => return N_Op_Concat;
when Name_Op_Expon => return N_Op_Expon;
when Name_Op_Subtract => return N_Op_Subtract;
when Name_Op_Mod => return N_Op_Mod;
when Name_Op_Multiply => return N_Op_Multiply;
when Name_Op_Divide => return N_Op_Divide;
when Name_Op_Rem => return N_Op_Rem;
when Name_Op_And => return N_Op_And;
when Name_Op_Eq => return N_Op_Eq;
when Name_Op_Ge => return N_Op_Ge;
when Name_Op_Gt => return N_Op_Gt;
when Name_Op_Le => return N_Op_Le;
when Name_Op_Lt => return N_Op_Lt;
when Name_Op_Ne => return N_Op_Ne;
when Name_Op_Or => return N_Op_Or;
when Name_Op_Xor => return N_Op_Xor;
when others => raise Program_Error;
end case;
end Get_Binary_Nkind;
@ -663,16 +645,11 @@ package body Sem_Aux is
function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind is
begin
case Chars (Op) is
when Name_Op_Abs =>
return N_Op_Abs;
when Name_Op_Subtract =>
return N_Op_Minus;
when Name_Op_Not =>
return N_Op_Not;
when Name_Op_Add =>
return N_Op_Plus;
when others =>
raise Program_Error;
when Name_Op_Abs => return N_Op_Abs;
when Name_Op_Subtract => return N_Op_Minus;
when Name_Op_Not => return N_Op_Not;
when Name_Op_Add => return N_Op_Plus;
when others => raise Program_Error;
end case;
end Get_Unary_Nkind;
@ -1556,7 +1533,9 @@ package body Sem_Aux is
when N_Subprogram_Body =>
return E;
when N_Subprogram_Declaration | N_Subprogram_Body_Stub =>
when N_Subprogram_Body_Stub
| N_Subprogram_Declaration
=>
return Corresponding_Body (N);
when others =>

Some files were not shown because too many files have changed in this diff Show More