diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2017-01-13 10:19:19 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2017-01-13 10:19:19 +0000 |
| commit | 99378362755a60c33ff00332ff58e05bc51d9da2 (patch) | |
| tree | f478a14a0fa94b8594e529f0aa178c5afedad3df /gcc/ada | |
| parent | 0b20de783f72340539a204893ed33a6370e949fe (diff) | |
| download | gcc-99378362755a60c33ff00332ff58e05bc51d9da2.tar.gz | |
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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@244406 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
129 files changed, 5112 insertions, 4533 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ea4f6bc12cf..8cac665e080 100644 --- a/gcc/ada/ChangeLog +++ b/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. diff --git a/gcc/ada/a-numaux-x86.adb b/gcc/ada/a-numaux-x86.adb index 5f245a2c37b..6f1f4624b60 100644 --- a/gcc/ada/a-numaux-x86.adb +++ b/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), diff --git a/gcc/ada/a-strfix.adb b/gcc/ada/a-strfix.adb index 69c0650df8e..2f140d8aa4a 100644 --- a/gcc/ada/a-strfix.adb +++ b/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 diff --git a/gcc/ada/a-stwifi.adb b/gcc/ada/a-stwifi.adb index dfe961995da..c586791100b 100644 --- a/gcc/ada/a-stwifi.adb +++ b/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 diff --git a/gcc/ada/a-stzfix.adb b/gcc/ada/a-stzfix.adb index 9176d400e03..b0087831d94 100644 --- a/gcc/ada/a-stzfix.adb +++ b/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); diff --git a/gcc/ada/a-stzsup.adb b/gcc/ada/a-stzsup.adb index d197a8fb7b5..acd003591ee 100644 --- a/gcc/ada/a-stzsup.adb +++ b/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 diff --git a/gcc/ada/a-teioed.adb b/gcc/ada/a-teioed.adb index 734917940fb..3c3e874f0d3 100644 --- a/gcc/ada/a-teioed.adb +++ b/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; diff --git a/gcc/ada/a-wtedit.adb b/gcc/ada/a-wtedit.adb index 4524f7ff6cc..32d62b97087 100644 --- a/gcc/ada/a-wtedit.adb +++ b/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; ---------------- diff --git a/gcc/ada/a-ztedit.adb b/gcc/ada/a-ztedit.adb index 5c7c9b4c3dd..bc759e05bb4 100644 --- a/gcc/ada/a-ztedit.adb +++ b/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; diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 7508e810eb4..d60d4980d0c 100644 --- a/gcc/ada/ali.adb +++ b/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; diff --git a/gcc/ada/binde.adb b/gcc/ada/binde.adb index f655bf2f2cf..ffb3b914a2a 100644 --- a/gcc/ada/binde.adb +++ b/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 diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 6913e8fb9b4..a42338b1ebf 100644 --- a/gcc/ada/checks.adb +++ b/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 => diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb index f7061d51c29..bbe34a60128 100644 --- a/gcc/ada/comperr.adb +++ b/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 => diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index e4e25bf0634..3a013d9257f 100644 --- a/gcc/ada/contracts.adb +++ b/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, diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index f007c2a4e3d..af9dc6975b8 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -8106,7 +8106,7 @@ package body Einfo is when 1 .. 6 => return Uint_128; when 7 .. 15 => return 2**10; when 16 .. 33 => return 2**14; - when others => return No_Uint; + when others => return No_Uint; end case; when AAMP => @@ -8141,14 +8141,14 @@ package body Einfo is when 7 .. 15 => return UI_From_Int (53); when 16 .. 18 => return Uint_64; when 19 .. 33 => return UI_From_Int (113); - when others => return No_Uint; + when others => return No_Uint; end case; when AAMP => case Digs is when 1 .. 6 => return Uint_24; when 7 .. 9 => return UI_From_Int (40); - when others => return No_Uint; + when others => return No_Uint; end case; end case; end Machine_Mantissa_Value; @@ -8160,7 +8160,9 @@ package body Einfo is function Machine_Radix_Value (Id : E) return U is begin case Float_Rep (Id) is - when IEEE_Binary | AAMP => + when AAMP + | IEEE_Binary + => return Uint_2; end case; end Machine_Radix_Value; @@ -8792,11 +8794,11 @@ package body Einfo is and then Is_Base_Type (Id)); case V is - when Calign_Default => + when Calign_Default => Set_Flag128 (Id, False); Set_Flag129 (Id, False); - when Calign_Component_Size => + when Calign_Component_Size => Set_Flag128 (Id, False); Set_Flag129 (Id, True); @@ -8804,7 +8806,7 @@ package body Einfo is Set_Flag128 (Id, True); Set_Flag129 (Id, False); - when Calign_Storage_Unit => + when Calign_Storage_Unit => Set_Flag128 (Id, True); Set_Flag129 (Id, True); end case; @@ -9022,60 +9024,68 @@ package body Einfo is begin case K is - when Access_Kind => + when Access_Kind => Kind := E_Access_Subtype; - when E_Array_Type | - E_Array_Subtype => + when E_Array_Subtype + | E_Array_Type + => Kind := E_Array_Subtype; - when E_Class_Wide_Type | - E_Class_Wide_Subtype => + when E_Class_Wide_Subtype + | E_Class_Wide_Type + => Kind := E_Class_Wide_Subtype; - when E_Decimal_Fixed_Point_Type | - E_Decimal_Fixed_Point_Subtype => + when E_Decimal_Fixed_Point_Subtype + | E_Decimal_Fixed_Point_Type + => Kind := E_Decimal_Fixed_Point_Subtype; - when E_Ordinary_Fixed_Point_Type | - E_Ordinary_Fixed_Point_Subtype => + when E_Ordinary_Fixed_Point_Subtype + | E_Ordinary_Fixed_Point_Type + => Kind := E_Ordinary_Fixed_Point_Subtype; - when E_Private_Type | - E_Private_Subtype => + when E_Private_Subtype + | E_Private_Type + => Kind := E_Private_Subtype; - when E_Limited_Private_Type | - E_Limited_Private_Subtype => + when E_Limited_Private_Subtype + | E_Limited_Private_Type + => Kind := E_Limited_Private_Subtype; - when E_Record_Type_With_Private | - E_Record_Subtype_With_Private => + when E_Record_Subtype_With_Private + | E_Record_Type_With_Private + => Kind := E_Record_Subtype_With_Private; - when E_Record_Type | - E_Record_Subtype => + when E_Record_Subtype + | E_Record_Type + => Kind := E_Record_Subtype; - when Enumeration_Kind => + when Enumeration_Kind => Kind := E_Enumeration_Subtype; - when Float_Kind => + when Float_Kind => Kind := E_Floating_Point_Subtype; - when Signed_Integer_Kind => + when Signed_Integer_Kind => Kind := E_Signed_Integer_Subtype; - when Modular_Integer_Kind => + when Modular_Integer_Kind => Kind := E_Modular_Integer_Subtype; - when Protected_Kind => + when Protected_Kind => Kind := E_Protected_Subtype; - when Task_Kind => + when Task_Kind => Kind := E_Task_Subtype; - when others => + when others => Kind := E_Void; raise Program_Error; end case; @@ -9583,7 +9593,6 @@ package body Einfo is Write_Eol; case Ekind (Id) is - when Discrete_Kind => Write_Str ("Bounds: Id = "); @@ -9643,7 +9652,8 @@ package body Einfo is Write_Eol; end if; - when others => null; + when others => + null; end case; end Write_Entity_Info; @@ -9674,34 +9684,36 @@ package body Einfo is procedure Write_Field8_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Type_Kind => + when Type_Kind => Write_Str ("Associated_Node_For_Itype"); - when E_Package => + when E_Package => Write_Str ("Dependent_Instances"); - when E_Loop => + when E_Loop => Write_Str ("First_Exit_Statement"); - when E_Variable => + when E_Variable => Write_Str ("Hiding_Loop_Variable"); - when Formal_Kind | - E_Function | - E_Subprogram_Body => + when Formal_Kind + | E_Function + | E_Subprogram_Body + => Write_Str ("Mechanism"); - when E_Component | - E_Discriminant => + when E_Component + | E_Discriminant + => Write_Str ("Normalized_First_Bit"); - when E_Abstract_State => + when E_Abstract_State => Write_Str ("Refinement_Constituents"); - when E_Return_Statement => + when E_Return_Statement => Write_Str ("Return_Applies_To"); - when others => + when others => Write_Str ("Field8??"); end case; end Write_Field8_Name; @@ -9713,21 +9725,22 @@ package body Einfo is procedure Write_Field9_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Type_Kind => + when Type_Kind => Write_Str ("Class_Wide_Type"); - when Object_Kind => + when Object_Kind => Write_Str ("Current_Value"); - when E_Function | - E_Generic_Function | - E_Generic_Package | - E_Generic_Procedure | - E_Package | - E_Procedure => + when E_Function + | E_Generic_Function + | E_Generic_Package + | E_Generic_Procedure + | E_Package + | E_Procedure + => Write_Str ("Renaming_Map"); - when others => + when others => Write_Str ("Field9??"); end case; end Write_Field9_Name; @@ -9739,36 +9752,41 @@ package body Einfo is procedure Write_Field10_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Class_Wide_Kind | - Incomplete_Kind | - E_Record_Type | - E_Record_Subtype | - Private_Kind | - Concurrent_Kind => + when Class_Wide_Kind + | Incomplete_Kind + | E_Record_Type + | E_Record_Subtype + | Private_Kind + | Concurrent_Kind + => Write_Str ("Direct_Primitive_Operations"); - when E_In_Parameter | - E_Constant => + when E_Constant + | E_In_Parameter + => Write_Str ("Discriminal_Link"); - when Float_Kind => + when Float_Kind => Write_Str ("Float_Rep"); - when E_Function | - E_Package | - E_Package_Body | - E_Procedure => + when E_Function + | E_Package + | E_Package_Body + | E_Procedure + => Write_Str ("Handler_Records"); - when E_Component | - E_Discriminant => + when E_Component + | E_Discriminant + => Write_Str ("Normalized_Position_Max"); - when E_Abstract_State | - E_Variable => + when E_Abstract_State + | E_Variable + => Write_Str ("Part_Of_Constituents"); - when others => + when others => Write_Str ("Field10??"); end case; end Write_Field10_Name; @@ -9780,36 +9798,39 @@ package body Einfo is procedure Write_Field11_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Block => + when E_Block => Write_Str ("Block_Node"); - when E_Component | - E_Discriminant => + when E_Component + | E_Discriminant + => Write_Str ("Component_Bit_Offset"); - when Formal_Kind => + when Formal_Kind => Write_Str ("Entry_Component"); - when E_Enumeration_Literal => + when E_Enumeration_Literal => Write_Str ("Enumeration_Pos"); - when Type_Kind | - E_Constant => + when Type_Kind + | E_Constant + => Write_Str ("Full_View"); - when E_Generic_Package => + when E_Generic_Package => Write_Str ("Generic_Homonym"); - when E_Variable => + when E_Variable => Write_Str ("Part_Of_References"); - when E_Entry | - E_Entry_Family | - E_Function | - E_Procedure => + when E_Entry + | E_Entry_Family + | E_Function + | E_Procedure + => Write_Str ("Protected_Body_Subprogram"); - when others => + when others => Write_Str ("Field11??"); end case; end Write_Field11_Name; @@ -9821,32 +9842,34 @@ package body Einfo is procedure Write_Field12_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Package => + when E_Package => Write_Str ("Associated_Formal_Package"); - when Entry_Kind => + when Entry_Kind => Write_Str ("Barrier_Function"); - when E_Enumeration_Literal => + when E_Enumeration_Literal => Write_Str ("Enumeration_Rep"); - when Type_Kind | - E_Component | - E_Constant | - E_Discriminant | - E_Exception | - E_In_Parameter | - E_In_Out_Parameter | - E_Out_Parameter | - E_Loop_Parameter | - E_Variable => + when Type_Kind + | E_Component + | E_Constant + | E_Discriminant + | E_Exception + | E_In_Parameter + | E_In_Out_Parameter + | E_Out_Parameter + | E_Loop_Parameter + | E_Variable + => Write_Str ("Esize"); - when E_Function | - E_Procedure => + when E_Function + | E_Procedure + => Write_Str ("Next_Inlined_Subprogram"); - when others => + when others => Write_Str ("Field12??"); end case; end Write_Field12_Name; @@ -9858,26 +9881,27 @@ package body Einfo is procedure Write_Field13_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Component | - E_Discriminant => + when E_Component + | E_Discriminant + => Write_Str ("Component_Clause"); - when E_Function => + when E_Function + | E_Procedure + | E_Package + | Generic_Unit_Kind + => Write_Str ("Elaboration_Entity"); - when E_Procedure | - E_Package | - Generic_Unit_Kind => - Write_Str ("Elaboration_Entity"); - - when Formal_Kind | - E_Variable => + when Formal_Kind + | E_Variable + => Write_Str ("Extra_Accessibility"); - when Type_Kind => + when Type_Kind => Write_Str ("RM_Size"); - when others => + when others => Write_Str ("Field13??"); end case; end Write_Field13_Name; @@ -9889,29 +9913,33 @@ package body Einfo is procedure Write_Field14_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Type_Kind | - Formal_Kind | - E_Constant | - E_Exception | - E_Loop_Parameter | - E_Variable => + when Type_Kind + | Formal_Kind + | E_Constant + | E_Exception + | E_Loop_Parameter + | E_Variable + => Write_Str ("Alignment"); - when E_Component | - E_Discriminant => + when E_Component + | E_Discriminant + => Write_Str ("Normalized_Position"); - when E_Entry | - E_Entry_Family | - E_Function | - E_Procedure => + when E_Entry + | E_Entry_Family + | E_Function + | E_Procedure + => Write_Str ("Postconditions_Proc"); - when E_Generic_Package | - E_Package => + when E_Generic_Package + | E_Package + => Write_Str ("Shadow_Entities"); - when others => + when others => Write_Str ("Field14??"); end case; end Write_Field14_Name; @@ -9923,34 +9951,37 @@ package body Einfo is procedure Write_Field15_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Discriminant => + when E_Discriminant => Write_Str ("Discriminant_Number"); - when E_Component => + when E_Component => Write_Str ("DT_Entry_Count"); - when E_Function | - E_Procedure => + when E_Function + | E_Procedure + => Write_Str ("DT_Position"); - when Entry_Kind => + when Entry_Kind => Write_Str ("Entry_Parameters_Type"); - when Formal_Kind => + when Formal_Kind => Write_Str ("Extra_Formal"); - when Type_Kind => + when Type_Kind => Write_Str ("Pending_Access_Types"); - when E_Package | - E_Package_Body => + when E_Package + | E_Package_Body + => Write_Str ("Related_Instance"); - when E_Constant | - E_Variable => + when E_Constant + | E_Variable + => Write_Str ("Status_Flag_Or_Transient_Decl"); - when others => + when others => Write_Str ("Field15??"); end case; end Write_Field15_Name; @@ -9962,43 +9993,48 @@ package body Einfo is procedure Write_Field16_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Record_Type | - E_Record_Type_With_Private => + when E_Record_Type + | E_Record_Type_With_Private + => Write_Str ("Access_Disp_Table"); - when E_Abstract_State => + when E_Abstract_State => Write_Str ("Body_References"); - when E_Record_Subtype | - E_Class_Wide_Subtype => + when E_Class_Wide_Subtype + | E_Record_Subtype + => Write_Str ("Cloned_Subtype"); - when E_Function | - E_Procedure => + when E_Function + | E_Procedure + => Write_Str ("DTC_Entity"); - when E_Component => + when E_Component => Write_Str ("Entry_Formal"); - when E_Package | - E_Generic_Package | - Concurrent_Kind => + when Concurrent_Kind + | E_Generic_Package + | E_Package + => Write_Str ("First_Private_Entity"); - when Enumeration_Kind => + when Enumeration_Kind => Write_Str ("Lit_Strings"); - when Decimal_Fixed_Point_Kind => + when Decimal_Fixed_Point_Kind => Write_Str ("Scale_Value"); - when E_String_Literal_Subtype => + when E_String_Literal_Subtype => Write_Str ("String_Literal_Length"); - when E_Variable | - E_Out_Parameter => + when E_Out_Parameter + | E_Variable + => Write_Str ("Unset_Reference"); - when others => + when others => Write_Str ("Field16??"); end case; end Write_Field16_Name; @@ -10010,56 +10046,58 @@ package body Einfo is procedure Write_Field17_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Formal_Kind | - E_Constant | - E_Generic_In_Out_Parameter | - E_Variable => + when Formal_Kind + | E_Constant + | E_Generic_In_Out_Parameter + | E_Variable + => Write_Str ("Actual_Subtype"); - when Digits_Kind => + when Digits_Kind => Write_Str ("Digits_Value"); - when E_Discriminant => + when E_Discriminant => Write_Str ("Discriminal"); - when E_Block | - Class_Wide_Kind | - Concurrent_Kind | - Private_Kind | - E_Entry | - E_Entry_Family | - E_Function | - E_Generic_Function | - E_Generic_Package | - E_Generic_Procedure | - E_Loop | - E_Operator | - E_Package | - E_Package_Body | - E_Procedure | - E_Record_Type | - E_Record_Subtype | - E_Return_Statement | - E_Subprogram_Body | - E_Subprogram_Type => + when Class_Wide_Kind + | Concurrent_Kind + | Private_Kind + | E_Block + | E_Entry + | E_Entry_Family + | E_Function + | E_Generic_Function + | E_Generic_Package + | E_Generic_Procedure + | E_Loop + | E_Operator + | E_Package + | E_Package_Body + | E_Procedure + | E_Record_Type + | E_Record_Subtype + | E_Return_Statement + | E_Subprogram_Body + | E_Subprogram_Type + => Write_Str ("First_Entity"); - when Array_Kind => + when Array_Kind => Write_Str ("First_Index"); - when Enumeration_Kind => + when Enumeration_Kind => Write_Str ("First_Literal"); - when Access_Kind => + when Access_Kind => Write_Str ("Master_Id"); - when Modular_Integer_Kind => + when Modular_Integer_Kind => Write_Str ("Modulus"); - when E_Component => + when E_Component => Write_Str ("Prival"); - when others => + when others => Write_Str ("Field17??"); end case; end Write_Field17_Name; @@ -10071,60 +10109,65 @@ package body Einfo is procedure Write_Field18_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Enumeration_Literal | - E_Function | - E_Operator | - E_Procedure => + when E_Enumeration_Literal + | E_Function + | E_Operator + | E_Procedure + => Write_Str ("Alias"); - when E_Record_Type => + when E_Record_Type => Write_Str ("Corresponding_Concurrent_Type"); - when E_Subprogram_Body => + when E_Subprogram_Body => Write_Str ("Corresponding_Protected_Entry"); - when Concurrent_Kind => + when Concurrent_Kind => Write_Str ("Corresponding_Record_Type"); - when E_Label | - E_Loop | - E_Block => + when E_Block + | E_Label + | E_Loop + => Write_Str ("Enclosing_Scope"); - when E_Entry_Index_Parameter => + when E_Entry_Index_Parameter => Write_Str ("Entry_Index_Constant"); - when E_Class_Wide_Subtype | - E_Access_Protected_Subprogram_Type | - E_Anonymous_Access_Protected_Subprogram_Type | - E_Access_Subprogram_Type | - E_Exception_Type => + when E_Access_Protected_Subprogram_Type + | E_Access_Subprogram_Type + | E_Anonymous_Access_Protected_Subprogram_Type + | E_Exception_Type + | E_Class_Wide_Subtype + => Write_Str ("Equivalent_Type"); - when Fixed_Point_Kind => + when Fixed_Point_Kind => Write_Str ("Delta_Value"); - when Enumeration_Kind => + when Enumeration_Kind => Write_Str ("Lit_Indexes"); - when Incomplete_Or_Private_Kind | - E_Record_Subtype => + when Incomplete_Or_Private_Kind + | E_Record_Subtype + => Write_Str ("Private_Dependents"); - when Object_Kind => - Write_Str ("Renamed_Object"); - - when E_Exception | - E_Package | - E_Generic_Function | - E_Generic_Procedure | - E_Generic_Package => + when E_Exception + | E_Generic_Function + | E_Generic_Package + | E_Generic_Procedure + | E_Package + => Write_Str ("Renamed_Entity"); - when E_String_Literal_Subtype => + when Object_Kind => + Write_Str ("Renamed_Object"); + + when E_String_Literal_Subtype => Write_Str ("String_Literal_Low_Bound"); - when others => + when others => Write_Str ("Field18??"); end case; end Write_Field18_Name; @@ -10136,52 +10179,57 @@ package body Einfo is procedure Write_Field19_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Package | - E_Generic_Package => + when E_Generic_Package + | E_Package + => Write_Str ("Body_Entity"); - when E_Discriminant => + when E_Discriminant => Write_Str ("Corresponding_Discriminant"); - when Scalar_Kind => + when Scalar_Kind => Write_Str ("Default_Aspect_Value"); - when E_Abstract_State | - E_Class_Wide_Type | - E_Incomplete_Type => - Write_Str ("Non_Limited_View"); - - when E_Incomplete_Subtype => - if From_Limited_With (Id) then - Write_Str ("Non_Limited_View"); - end if; - - when E_Array_Type => + when E_Array_Type => Write_Str ("Default_Component_Value"); - when E_Protected_Type => + when E_Protected_Type => Write_Str ("Entry_Bodies_Array"); - when E_Function | - E_Operator | - E_Subprogram_Type => + when E_Function + | E_Operator + | E_Subprogram_Type + => Write_Str ("Extra_Accessibility_Of_Result"); - when E_Record_Type => + when E_Abstract_State + | E_Class_Wide_Type + | E_Incomplete_Type + => + Write_Str ("Non_Limited_View"); + + when E_Incomplete_Subtype => + if From_Limited_With (Id) then + Write_Str ("Non_Limited_View"); + end if; + + when E_Record_Type => Write_Str ("Parent_Subtype"); - when E_Constant | - E_Variable => + when E_Constant + | E_Variable + => Write_Str ("Size_Check_Code"); - when E_Package_Body | - Formal_Kind => + when Formal_Kind + | E_Package_Body + => Write_Str ("Spec_Entity"); - when Private_Kind => + when Private_Kind => Write_Str ("Underlying_Full_View"); - when others => + when others => Write_Str ("Field19??"); end case; end Write_Field19_Name; @@ -10193,55 +10241,58 @@ package body Einfo is procedure Write_Field20_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Array_Kind => + when Array_Kind => Write_Str ("Component_Type"); - when E_In_Parameter | - E_Generic_In_Parameter => + when E_Generic_In_Parameter + | E_In_Parameter + => Write_Str ("Default_Value"); - when Access_Kind => + when Access_Kind => Write_Str ("Directly_Designated_Type"); - when E_Component => + when E_Component => Write_Str ("Discriminant_Checking_Func"); - when E_Discriminant => + when E_Discriminant => Write_Str ("Discriminant_Default_Value"); - when E_Block | - Class_Wide_Kind | - Concurrent_Kind | - Private_Kind | - E_Entry | - E_Entry_Family | - E_Function | - E_Generic_Function | - E_Generic_Package | - E_Generic_Procedure | - E_Loop | - E_Operator | - E_Package | - E_Package_Body | - E_Procedure | - E_Record_Type | - E_Record_Subtype | - E_Return_Statement | - E_Subprogram_Body | - E_Subprogram_Type => + when Class_Wide_Kind + | Concurrent_Kind + | Private_Kind + | E_Block + | E_Entry + | E_Entry_Family + | E_Function + | E_Generic_Function + | E_Generic_Package + | E_Generic_Procedure + | E_Loop + | E_Operator + | E_Package + | E_Package_Body + | E_Procedure + | E_Record_Type + | E_Record_Subtype + | E_Return_Statement + | E_Subprogram_Body + | E_Subprogram_Type + => Write_Str ("Last_Entity"); - when E_Constant | - E_Variable => + when E_Constant + | E_Variable + => Write_Str ("Prival_Link"); - when Scalar_Kind => - Write_Str ("Scalar_Range"); - - when E_Exception => + when E_Exception => Write_Str ("Register_Exception_Call"); - when others => + when Scalar_Kind => + Write_Str ("Scalar_Range"); + + when others => Write_Str ("Field20??"); end case; end Write_Field20_Name; @@ -10253,36 +10304,39 @@ package body Einfo is procedure Write_Field21_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Entry_Kind => + when Entry_Kind => Write_Str ("Accept_Address"); - when E_In_Parameter => + when E_In_Parameter => Write_Str ("Default_Expr_Function"); - when Concurrent_Kind | - Incomplete_Or_Private_Kind | - Class_Wide_Kind | - E_Record_Type | - E_Record_Subtype => + when Concurrent_Kind + | Incomplete_Or_Private_Kind + | Class_Wide_Kind + | E_Record_Type + | E_Record_Subtype + => Write_Str ("Discriminant_Constraint"); - when E_Constant | - E_Exception | - E_Function | - E_Generic_Function | - E_Procedure | - E_Generic_Procedure | - E_Variable => + when E_Constant + | E_Exception + | E_Function + | E_Generic_Function + | E_Generic_Procedure + | E_Procedure + | E_Variable + => Write_Str ("Interface_Name"); - when Array_Kind | - Modular_Integer_Kind => + when Array_Kind + | Modular_Integer_Kind + => Write_Str ("Original_Array_Type"); - when Fixed_Point_Kind => + when Fixed_Point_Kind => Write_Str ("Small_Value"); - when others => + when others => Write_Str ("Field21??"); end case; end Write_Field21_Name; @@ -10294,54 +10348,57 @@ package body Einfo is procedure Write_Field22_Name (Id : Entity_Id) is begin case Ekind (Id) is - when Access_Kind => + when Access_Kind => Write_Str ("Associated_Storage_Pool"); - when Array_Kind => + when Array_Kind => Write_Str ("Component_Size"); - when E_Record_Type => + when E_Record_Type => Write_Str ("Corresponding_Remote_Type"); - when E_Component | - E_Discriminant => + when E_Component + | E_Discriminant + => Write_Str ("Original_Record_Component"); - when E_Enumeration_Literal => + when E_Enumeration_Literal => Write_Str ("Enumeration_Rep_Expr"); - when E_Record_Type_With_Private | - E_Record_Subtype_With_Private | - E_Private_Type | - E_Private_Subtype | - E_Limited_Private_Type | - E_Limited_Private_Subtype => + when E_Limited_Private_Subtype + | E_Limited_Private_Type + | E_Private_Subtype + | E_Private_Type + | E_Record_Subtype_With_Private + | E_Record_Type_With_Private + => Write_Str ("Private_View"); - when Formal_Kind => + when Formal_Kind => Write_Str ("Protected_Formal"); - when E_Block | - E_Entry | - E_Entry_Family | - E_Function | - E_Loop | - E_Package | - E_Package_Body | - E_Generic_Package | - E_Generic_Function | - E_Generic_Procedure | - E_Procedure | - E_Protected_Type | - E_Return_Statement | - E_Subprogram_Body | - E_Task_Type => + when E_Block + | E_Entry + | E_Entry_Family + | E_Function + | E_Generic_Function + | E_Generic_Package + | E_Generic_Procedure + | E_Loop + | E_Package + | E_Package_Body + | E_Procedure + | E_Protected_Type + | E_Return_Statement + | E_Subprogram_Body + | E_Task_Type + => Write_Str ("Scope_Depth_Value"); - when E_Variable => + when E_Variable => Write_Str ("Shared_Var_Procs_Instance"); - when others => + when others => Write_Str ("Field22??"); end case; end Write_Field22_Name; @@ -10353,42 +10410,46 @@ package body Einfo is procedure Write_Field23_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Discriminant => + when E_Discriminant => Write_Str ("CR_Discriminant"); - when E_Block => + when E_Block => Write_Str ("Entry_Cancel_Parameter"); - when E_Enumeration_Type => + when E_Enumeration_Type => Write_Str ("Enum_Pos_To_Rep"); - when Formal_Kind | - E_Variable => + when Formal_Kind + | E_Variable + => Write_Str ("Extra_Constrained"); - when Access_Kind => + when Access_Kind => Write_Str ("Finalization_Master"); - when E_Generic_Function | - E_Generic_Package | - E_Generic_Procedure => + when E_Generic_Function + | E_Generic_Package + | E_Generic_Procedure + => Write_Str ("Inner_Instances"); - when Array_Kind => + when Array_Kind => Write_Str ("Packed_Array_Impl_Type"); - when Entry_Kind => + when Entry_Kind => Write_Str ("Protection_Object"); - when Concurrent_Kind | - Incomplete_Or_Private_Kind | - Class_Wide_Kind | - E_Record_Type | - E_Record_Subtype => + when Class_Wide_Kind + | Concurrent_Kind + | Incomplete_Or_Private_Kind + | E_Record_Type + | E_Record_Subtype + => Write_Str ("Stored_Constraint"); - when E_Function | - E_Procedure => + when E_Function + | E_Procedure + => if Present (Scope (Id)) and then Is_Protected_Type (Scope (Id)) then @@ -10397,14 +10458,14 @@ package body Einfo is Write_Str ("Generic_Renamings"); end if; - when E_Package => + when E_Package => if Is_Generic_Instance (Id) then Write_Str ("Generic_Renamings"); else Write_Str ("Limited_View"); end if; - when others => + when others => Write_Str ("Field23??"); end case; end Write_Field23_Name; @@ -10416,20 +10477,22 @@ package body Einfo is procedure Write_Field24_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Constant | - E_Variable | - Type_Kind => + when Type_Kind + | E_Constant + | E_Variable + => Write_Str ("Related_Expression"); - when E_Function | - E_Operator | - E_Procedure => + when E_Function + | E_Operator + | E_Procedure + => Write_Str ("Subps_Index"); - when E_Package => + when E_Package => Write_Str ("Incomplete_Actuals"); - when others => + when others => Write_Str ("Field24???"); end case; end Write_Field24_Name; @@ -10441,44 +10504,49 @@ package body Einfo is procedure Write_Field25_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Generic_Package | - E_Package => + when E_Generic_Package + | E_Package + => Write_Str ("Abstract_States"); - when E_Entry | - E_Entry_Family => + when E_Entry + | E_Entry_Family + => Write_Str ("Contract_Wrapper"); - when E_Variable => + when E_Variable => Write_Str ("Debug_Renaming_Link"); - when E_Component => + when E_Component => Write_Str ("DT_Offset_To_Top_Func"); - when E_Procedure | - E_Function => + when E_Function + | E_Procedure + => Write_Str ("Interface_Alias"); - when E_Record_Type | - E_Record_Subtype | - E_Record_Type_With_Private | - E_Record_Subtype_With_Private => + when E_Record_Subtype + | E_Record_Subtype_With_Private + | E_Record_Type + | E_Record_Type_With_Private + => Write_Str ("Interfaces"); - when E_Array_Type | - E_Array_Subtype => + when E_Array_Subtype + | E_Array_Type + => Write_Str ("Related_Array_Object"); - when Task_Kind => - Write_Str ("Task_Body_Procedure"); - - when Discrete_Kind => + when Discrete_Kind => Write_Str ("Static_Discrete_Predicate"); - when Real_Kind => + when Real_Kind => Write_Str ("Static_Real_Or_String_Predicate"); - when others => + when Task_Kind => + Write_Str ("Task_Body_Procedure"); + + when others => Write_Str ("Field25??"); end case; end Write_Field25_Name; @@ -10490,32 +10558,38 @@ package body Einfo is procedure Write_Field26_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Record_Type | - E_Record_Type_With_Private => + when E_Record_Type + | E_Record_Type_With_Private + => Write_Str ("Dispatch_Table_Wrappers"); - when E_In_Out_Parameter | - E_Out_Parameter | - E_Variable => + when E_In_Out_Parameter + | E_Out_Parameter + | E_Variable + => Write_Str ("Last_Assignment"); - when E_Procedure | - E_Function => + when E_Function + | E_Procedure + => Write_Str ("Overridden_Operation"); - when E_Generic_Package | - E_Package => + when E_Generic_Package + | E_Package + => Write_Str ("Package_Instantiation"); - when E_Component | - E_Constant => + when E_Component + | E_Constant + => Write_Str ("Related_Type"); - when Access_Kind | - Task_Kind => + when Access_Kind + | Task_Kind + => Write_Str ("Storage_Size_Variable"); - when others => + when others => Write_Str ("Field26??"); end case; end Write_Field26_Name; @@ -10527,20 +10601,23 @@ package body Einfo is procedure Write_Field27_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Package | - Type_Kind => + when Type_Kind + | E_Package + => Write_Str ("Current_Use_Clause"); - when E_Component | - E_Constant | - E_Variable => + when E_Component + | E_Constant + | E_Variable + => Write_Str ("Related_Type"); - when E_Procedure | - E_Function => + when E_Function + | E_Procedure + => Write_Str ("Wrapped_Entity"); - when others => + when others => Write_Str ("Field27??"); end case; end Write_Field27_Name; @@ -10552,32 +10629,35 @@ package body Einfo is procedure Write_Field28_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Entry | - E_Entry_Family | - E_Function | - E_Procedure | - E_Subprogram_Body | - E_Subprogram_Type => + when E_Entry + | E_Entry_Family + | E_Function + | E_Procedure + | E_Subprogram_Body + | E_Subprogram_Type + => Write_Str ("Extra_Formals"); - when E_Package | - E_Package_Body => + when E_Package + | E_Package_Body + => Write_Str ("Finalizer"); - when E_Constant | - E_Variable => + when E_Constant + | E_Variable + => Write_Str ("Initialization_Statements"); - when E_Access_Subprogram_Type => + when E_Access_Subprogram_Type => Write_Str ("Original_Access_Type"); - when Task_Kind => + when Task_Kind => Write_Str ("Relative_Deadline_Variable"); when E_Record_Type => Write_Str ("Underlying_Record_View"); - when others => + when others => Write_Str ("Field28??"); end case; end Write_Field28_Name; @@ -10589,20 +10669,22 @@ package body Einfo is procedure Write_Field29_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Function | - E_Package | - E_Procedure | - E_Subprogram_Body => + when E_Function + | E_Package + | E_Procedure + | E_Subprogram_Body + => Write_Str ("Anonymous_Masters"); - when E_Constant | - E_Variable => + when E_Constant + | E_Variable + => Write_Str ("BIP_Initialization_Call"); when Type_Kind => Write_Str ("Subprograms_For_Type"); - when others => + when others => Write_Str ("Field29??"); end case; end Write_Field29_Name; @@ -10614,21 +10696,23 @@ package body Einfo is procedure Write_Field30_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Protected_Type | - E_Task_Type => + when E_Protected_Type + | E_Task_Type + => Write_Str ("Anonymous_Object"); - when E_Function => + when E_Function => Write_Str ("Corresponding_Equality"); - when E_Constant | - E_Variable => + when E_Constant + | E_Variable + => Write_Str ("Last_Aggregate_Assignment"); - when E_Procedure => + when E_Procedure => Write_Str ("Static_Initialization"); - when others => + when others => Write_Str ("Field30??"); end case; end Write_Field30_Name; @@ -10640,22 +10724,24 @@ package body Einfo is procedure Write_Field31_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Procedure | - E_Function => - Write_Str ("Thunk_Entity"); + when E_Constant + | E_In_Parameter + | E_In_Out_Parameter + | E_Loop_Parameter + | E_Out_Parameter + | E_Variable + => + Write_Str ("Activation_Record_Component"); - when Type_Kind => + when Type_Kind => Write_Str ("Derived_Type_Link"); - when E_Constant | - E_In_Parameter | - E_In_Out_Parameter | - E_Loop_Parameter | - E_Out_Parameter | - E_Variable => - Write_Str ("Activation_Record_Component"); + when E_Function + | E_Procedure + => + Write_Str ("Thunk_Entity"); - when others => + when others => Write_Str ("Field31??"); end case; end Write_Field31_Name; @@ -10667,21 +10753,22 @@ package body Einfo is procedure Write_Field32_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Abstract_State | - E_Constant | - E_Variable => - Write_Str ("Encapsulating_State"); + when E_Procedure => + Write_Str ("Corresponding_Function"); - when E_Function => + when E_Function => Write_Str ("Corresponding_Procedure"); - when E_Procedure => - Write_Str ("Corresponding_Function"); + when E_Abstract_State + | E_Constant + | E_Variable + => + Write_Str ("Encapsulating_State"); - when Type_Kind => + when Type_Kind => Write_Str ("No_Tagged_Streams_Pragma"); - when others => + when others => Write_Str ("Field32??"); end case; end Write_Field32_Name; @@ -10693,13 +10780,14 @@ package body Einfo is procedure Write_Field33_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Constant | - E_Variable | - Subprogram_Kind | - Type_Kind => + when Subprogram_Kind + | Type_Kind + | E_Constant + | E_Variable + => Write_Str ("Linker_Section_Pragma"); - when others => + when others => Write_Str ("Field33??"); end case; end Write_Field33_Name; @@ -10711,26 +10799,27 @@ package body Einfo is procedure Write_Field34_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Constant | - E_Entry | - E_Entry_Family | - E_Function | - E_Generic_Function | - E_Generic_Package | - E_Generic_Procedure | - E_Operator | - E_Package | - E_Package_Body | - E_Procedure | - E_Protected_Type | - E_Subprogram_Body | - E_Task_Body | - E_Task_Type | - E_Variable | - E_Void => + when E_Constant + | E_Entry + | E_Entry_Family + | E_Function + | E_Generic_Function + | E_Generic_Package + | E_Generic_Procedure + | E_Operator + | E_Package + | E_Package_Body + | E_Procedure + | E_Protected_Type + | E_Subprogram_Body + | E_Task_Body + | E_Task_Type + | E_Variable + | E_Void + => Write_Str ("Contract"); - when others => + when others => Write_Str ("Field34??"); end case; end Write_Field34_Name; @@ -10742,17 +10831,18 @@ package body Einfo is procedure Write_Field35_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Variable => + when E_Variable => Write_Str ("Anonymous_Designated_Type"); - when E_Entry | - E_Entry_Family => + when E_Entry + | E_Entry_Family + => Write_Str ("Entry_Max_Queue_Lenghts_Array"); - when Subprogram_Kind => + when Subprogram_Kind => Write_Str ("Import_Pragma"); - when others => + when others => Write_Str ("Field35??"); end case; end Write_Field35_Name; @@ -10784,11 +10874,12 @@ package body Einfo is procedure Write_Field38_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Function | - E_Procedure => - Write_Str ("Class-wide preconditions"); + when E_Function + | E_Procedure + => + Write_Str ("Class_Wide_Preconditions"); - when others => + when others => Write_Str ("Field38??"); end case; end Write_Field38_Name; @@ -10800,11 +10891,12 @@ package body Einfo is procedure Write_Field39_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Function | - E_Procedure => - Write_Str ("Class-wide postcondition"); + when E_Function + | E_Procedure + => + Write_Str ("Class_Wide_Postcondition"); - when others => + when others => Write_Str ("Field39??"); end case; end Write_Field39_Name; @@ -10816,25 +10908,26 @@ package body Einfo is procedure Write_Field40_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Entry | - E_Entry_Family | - E_Function | - E_Generic_Function | - E_Generic_Package | - E_Generic_Procedure | - E_Operator | - E_Package | - E_Package_Body | - E_Procedure | - E_Protected_Body | - E_Protected_Type | - E_Subprogram_Body | - E_Task_Body | - E_Task_Type | - E_Variable => + when E_Entry + | E_Entry_Family + | E_Function + | E_Generic_Function + | E_Generic_Package + | E_Generic_Procedure + | E_Operator + | E_Package + | E_Package_Body + | E_Procedure + | E_Protected_Body + | E_Protected_Type + | E_Subprogram_Body + | E_Task_Body + | E_Task_Type + | E_Variable + => Write_Str ("SPARK_Pragma"); - when others => + when others => Write_Str ("Field40??"); end case; end Write_Field40_Name; @@ -10846,18 +10939,20 @@ package body Einfo is procedure Write_Field41_Name (Id : Entity_Id) is begin case Ekind (Id) is - when E_Generic_Package | - E_Package | - E_Package_Body | - E_Protected_Type | - E_Task_Type => - Write_Str ("SPARK_Aux_Pragma"); - - when E_Function | - E_Procedure => + when E_Function + | E_Procedure + => Write_Str ("Original_Protected_Subprogram"); - when others => + when E_Generic_Package + | E_Package + | E_Package_Body + | E_Protected_Type + | E_Task_Type + => + Write_Str ("SPARK_Aux_Pragma"); + + when others => Write_Str ("Field41??"); end case; end Write_Field41_Name; diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 984090e0d2c..7a244fb5800 100644 --- a/gcc/ada/errout.adb +++ b/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; diff --git a/gcc/ada/eval_fat.adb b/gcc/ada/eval_fat.adb index df6e35aab27..48208444bde 100644 --- a/gcc/ada/eval_fat.adb +++ b/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; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 074a5b1a6cf..5b8e0055a3e 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1752,12 +1752,13 @@ package body Exp_Attr is -- Attributes related to Ada 2012 iterators - when Attribute_Constant_Indexing | - Attribute_Default_Iterator | - Attribute_Implicit_Dereference | - Attribute_Iterable | - Attribute_Iterator_Element | - Attribute_Variable_Indexing => + when Attribute_Constant_Indexing + | Attribute_Default_Iterator + | Attribute_Implicit_Dereference + | Attribute_Iterable + | Attribute_Iterator_Element + | Attribute_Variable_Indexing + => null; -- Internal attributes used to deal with Ada 2012 delayed aspects. These @@ -1770,10 +1771,10 @@ package body Exp_Attr is -- Access -- ------------ - when Attribute_Access | - Attribute_Unchecked_Access | - Attribute_Unrestricted_Access => - + when Attribute_Access + | Attribute_Unchecked_Access + | Attribute_Unrestricted_Access + => Access_Cases : declare Ref_Object : constant Node_Id := Get_Referenced_Object (Pref); Btyp_DDT : Entity_Id; @@ -2340,99 +2341,103 @@ package body Exp_Attr is -- A special exception occurs for Standard, where the string returned -- is a copy of the library string in gnatvsn.ads. - when Attribute_Body_Version | Attribute_Version => Version : declare - E : constant Entity_Id := Make_Temporary (Loc, 'V'); - Pent : Entity_Id; - S : String_Id; + when Attribute_Body_Version + | Attribute_Version + => + Version : declare + E : constant Entity_Id := Make_Temporary (Loc, 'V'); + Pent : Entity_Id; + S : String_Id; - begin - -- If not library unit, get to containing library unit - - Pent := Entity (Pref); - while Pent /= Standard_Standard - and then Scope (Pent) /= Standard_Standard - and then not Is_Child_Unit (Pent) - loop - Pent := Scope (Pent); - end loop; + begin + -- If not library unit, get to containing library unit + + Pent := Entity (Pref); + while Pent /= Standard_Standard + and then Scope (Pent) /= Standard_Standard + and then not Is_Child_Unit (Pent) + loop + Pent := Scope (Pent); + end loop; - -- Special case Standard and Standard.ASCII + -- Special case Standard and Standard.ASCII - if Pent = Standard_Standard or else Pent = Standard_ASCII then - Rewrite (N, - Make_String_Literal (Loc, - Strval => Verbose_Library_Version)); + if Pent = Standard_Standard or else Pent = Standard_ASCII then + Rewrite (N, + Make_String_Literal (Loc, + Strval => Verbose_Library_Version)); - -- All other cases + -- All other cases - else - -- Build required string constant + else + -- Build required string constant - Get_Name_String (Get_Unit_Name (Pent)); + Get_Name_String (Get_Unit_Name (Pent)); - Start_String; - for J in 1 .. Name_Len - 2 loop - if Name_Buffer (J) = '.' then - Store_String_Chars ("__"); - else - Store_String_Char (Get_Char_Code (Name_Buffer (J))); - end if; - end loop; + Start_String; + for J in 1 .. Name_Len - 2 loop + if Name_Buffer (J) = '.' then + Store_String_Chars ("__"); + else + Store_String_Char (Get_Char_Code (Name_Buffer (J))); + end if; + end loop; - -- Case of subprogram acting as its own spec, always use body + -- Case of subprogram acting as its own spec, always use body - if Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification - and then Nkind (Parent (Declaration_Node (Pent))) = - N_Subprogram_Body - and then Acts_As_Spec (Parent (Declaration_Node (Pent))) - then - Store_String_Chars ("B"); + if Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification + and then Nkind (Parent (Declaration_Node (Pent))) = + N_Subprogram_Body + and then Acts_As_Spec (Parent (Declaration_Node (Pent))) + then + Store_String_Chars ("B"); - -- Case of no body present, always use spec + -- Case of no body present, always use spec - elsif not Unit_Requires_Body (Pent) then - Store_String_Chars ("S"); + elsif not Unit_Requires_Body (Pent) then + Store_String_Chars ("S"); - -- Otherwise use B for Body_Version, S for spec + -- Otherwise use B for Body_Version, S for spec - elsif Id = Attribute_Body_Version then - Store_String_Chars ("B"); - else - Store_String_Chars ("S"); - end if; + elsif Id = Attribute_Body_Version then + Store_String_Chars ("B"); + else + Store_String_Chars ("S"); + end if; - S := End_String; - Lib.Version_Referenced (S); + S := End_String; + Lib.Version_Referenced (S); - -- Insert the object declaration + -- Insert the object declaration - Insert_Actions (N, New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => E, - Object_Definition => - New_Occurrence_Of (RTE (RE_Unsigned), Loc)))); + Insert_Actions (N, New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => E, + Object_Definition => + New_Occurrence_Of (RTE (RE_Unsigned), Loc)))); - -- Set entity as imported with correct external name + -- Set entity as imported with correct external name - Set_Is_Imported (E); - Set_Interface_Name (E, Make_String_Literal (Loc, S)); + Set_Is_Imported (E); + Set_Interface_Name (E, Make_String_Literal (Loc, S)); - -- Set entity as internal to ensure proper Sprint output of its - -- implicit importation. + -- Set entity as internal to ensure proper Sprint output of its + -- implicit importation. - Set_Is_Internal (E); + Set_Is_Internal (E); - -- And now rewrite original reference + -- And now rewrite original reference - Rewrite (N, - Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (RE_Get_Version_String), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (E, Loc)))); - end if; + Rewrite (N, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_Version_String), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (E, Loc)))); + end if; - Analyze_And_Resolve (N, RTE (RE_Version_String)); - end Version; + Analyze_And_Resolve (N, RTE (RE_Version_String)); + end Version; ------------- -- Ceiling -- @@ -2450,8 +2455,7 @@ package body Exp_Attr is -- Transforms 'Callable attribute into a call to the Callable function - when Attribute_Callable => Callable : - begin + when Attribute_Callable => -- We have an object of a task interface class-wide type as a prefix -- to Callable. Generate: -- callable (Task_Id (Pref._disp_get_task_id)); @@ -2463,15 +2467,15 @@ package body Exp_Attr is then Rewrite (N, Make_Function_Call (Loc, - Name => + Name => New_Occurrence_Of (RTE (RE_Callable), Loc), Parameter_Associations => New_List ( Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), - Expression => + Expression => Make_Selected_Component (Loc, - Prefix => + Prefix => New_Copy_Tree (Pref), Selector_Name => Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))))); @@ -2482,7 +2486,6 @@ package body Exp_Attr is end if; Analyze_And_Resolve (N, Standard_Boolean); - end Callable; ------------ -- Caller -- @@ -2807,7 +2810,7 @@ package body Exp_Attr is Call := Make_Function_Call (Loc, - Name => Name, + Name => Name, Parameter_Associations => New_List ( New_Occurrence_Of (Find_Protection_Object (Current_Scope), Loc), @@ -2820,7 +2823,7 @@ package body Exp_Attr is Call := Make_Function_Call (Loc, - Name => Name, + Name => Name, Parameter_Associations => New_List ( New_Occurrence_Of (Find_Protection_Object (Current_Scope), Loc))); @@ -2893,9 +2896,9 @@ package body Exp_Attr is -- and then the Elab_Body/Spec attribute is replaced by a reference -- to this defining identifier. - when Attribute_Elab_Body | - Attribute_Elab_Spec => - + when Attribute_Elab_Body + | Attribute_Elab_Spec + => -- Leave attribute unexpanded in CodePeer mode: the gnat2scil -- back-end knows how to handle these attributes directly. @@ -3123,18 +3126,17 @@ package body Exp_Attr is -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag) - when Attribute_External_Tag => External_Tag : - begin + when Attribute_External_Tag => Rewrite (N, Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (RE_External_Tag), Loc), + Name => + New_Occurrence_Of (RTE (RE_External_Tag), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, Attribute_Name => Name_Tag, - Prefix => Prefix (N))))); + Prefix => Prefix (N))))); Analyze_And_Resolve (N, Standard_String); - end External_Tag; ----------------------- -- Finalization_Size -- @@ -3349,8 +3351,7 @@ package body Exp_Attr is -- that the back end always treats fixed-point as equivalent to the -- corresponding integer type anyway. - when Attribute_Fixed_Value => Fixed_Value : - begin + when Attribute_Fixed_Value => Rewrite (N, Make_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc), @@ -3358,12 +3359,12 @@ package body Exp_Attr is Set_Etype (N, Entity (Pref)); Set_Analyzed (N); - -- Note: it might appear that a properly analyzed unchecked conversion - -- would be just fine here, but that's not the case, since the full - -- range checks performed by the following call are critical. + -- Note: it might appear that a properly analyzed unchecked + -- conversion would be just fine here, but that's not the case, + -- since the full range checks performed by the following call + -- are critical. Apply_Type_Conversion_Checks (N); - end Fixed_Value; ----------- -- Floor -- @@ -3391,25 +3392,25 @@ package body Exp_Attr is -- Note that we know that the type is a non-static subtype, or Fore -- would have itself been computed dynamically in Eval_Attribute. - when Attribute_Fore => Fore : begin + when Attribute_Fore => Rewrite (N, Convert_To (Typ, Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (RE_Fore), Loc), + Name => + New_Occurrence_Of (RTE (RE_Fore), Loc), Parameter_Associations => New_List ( Convert_To (Universal_Real, Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Ptyp, Loc), + Prefix => New_Occurrence_Of (Ptyp, Loc), Attribute_Name => Name_First)), Convert_To (Universal_Real, Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Ptyp, Loc), + Prefix => New_Occurrence_Of (Ptyp, Loc), Attribute_Name => Name_Last)))))); Analyze_And_Resolve (N, Typ); - end Fore; -------------- -- Fraction -- @@ -3428,6 +3429,7 @@ package body Exp_Attr is when Attribute_From_Any => From_Any : declare P_Type : constant Entity_Id := Etype (Pref); Decls : constant List_Id := New_List; + begin Rewrite (N, Build_From_Any_Call (P_Type, @@ -3442,17 +3444,19 @@ package body Exp_Attr is ---------------------- when Attribute_Has_Same_Storage => Has_Same_Storage : declare - Loc : constant Source_Ptr := Sloc (N); + Loc : constant Source_Ptr := Sloc (N); - X : constant Node_Id := Prefix (N); - Y : constant Node_Id := First (Expressions (N)); - -- The arguments + X : constant Node_Id := Prefix (N); + Y : constant Node_Id := First (Expressions (N)); + -- The arguments - X_Addr, Y_Addr : Node_Id; - -- Rhe expressions for their addresses + X_Addr : Node_Id; + Y_Addr : Node_Id; + -- Rhe expressions for their addresses - X_Size, Y_Size : Node_Id; - -- Rhe expressions for their sizes + X_Size : Node_Id; + Y_Size : Node_Id; + -- Rhe expressions for their sizes begin -- The attribute is expanded as: @@ -3465,40 +3469,40 @@ package body Exp_Attr is X_Addr := Make_Attribute_Reference (Loc, - Attribute_Name => Name_Address, - Prefix => New_Copy_Tree (X)); + Attribute_Name => Name_Address, + Prefix => New_Copy_Tree (X)); Y_Addr := Make_Attribute_Reference (Loc, - Attribute_Name => Name_Address, - Prefix => New_Copy_Tree (Y)); + Attribute_Name => Name_Address, + Prefix => New_Copy_Tree (Y)); X_Size := Make_Attribute_Reference (Loc, - Attribute_Name => Name_Size, - Prefix => New_Copy_Tree (X)); + Attribute_Name => Name_Size, + Prefix => New_Copy_Tree (X)); Y_Size := Make_Attribute_Reference (Loc, - Attribute_Name => Name_Size, - Prefix => New_Copy_Tree (Y)); + Attribute_Name => Name_Size, + Prefix => New_Copy_Tree (Y)); if Etype (X) = Etype (Y) then Rewrite (N, - (Make_Op_Eq (Loc, - Left_Opnd => X_Addr, - Right_Opnd => Y_Addr))); + Make_Op_Eq (Loc, + Left_Opnd => X_Addr, + Right_Opnd => Y_Addr)); else Rewrite (N, - Make_Op_And (Loc, - Left_Opnd => - Make_Op_Eq (Loc, - Left_Opnd => X_Addr, - Right_Opnd => Y_Addr), - Right_Opnd => - Make_Op_Eq (Loc, - Left_Opnd => X_Size, - Right_Opnd => Y_Size))); + Make_Op_And (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => X_Addr, + Right_Opnd => Y_Addr), + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => X_Size, + Right_Opnd => Y_Size))); end if; Analyze_And_Resolve (N, Standard_Boolean); @@ -3575,8 +3579,7 @@ package body Exp_Attr is -- X'Img is expanded to typ'Image (X), where typ is the type of X - when Attribute_Img => Img : - begin + when Attribute_Img => Rewrite (N, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Ptyp, Loc), @@ -3584,7 +3587,6 @@ package body Exp_Attr is Expressions => New_List (Relocate_Node (Pref)))); Analyze_And_Resolve (N, Standard_String); - end Img; ----------- -- Input -- @@ -3896,8 +3898,7 @@ package body Exp_Attr is -- that the back end always treats fixed-point as equivalent to the -- corresponding integer type anyway. - when Attribute_Integer_Value => Integer_Value : - begin + when Attribute_Integer_Value => Rewrite (N, Make_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc), @@ -3905,12 +3906,11 @@ package body Exp_Attr is Set_Etype (N, Entity (Pref)); Set_Analyzed (N); - -- Note: it might appear that a properly analyzed unchecked conversion - -- would be just fine here, but that's not the case, since the full - -- range checks performed by the following call are critical. + -- Note: it might appear that a properly analyzed unchecked + -- conversion would be just fine here, but that's not the case, since + -- the full range check performed by the following call is critical. Apply_Type_Conversion_Checks (N); - end Integer_Value; ------------------- -- Invalid_Value -- @@ -4239,34 +4239,31 @@ package body Exp_Attr is -- (Integer'Integer_Value (typ'First), -- Integer'Integer_Value (typ'Last))); - when Attribute_Mantissa => Mantissa : begin + when Attribute_Mantissa => Rewrite (N, Convert_To (Typ, Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc), + Name => + New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc), Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Standard_Integer, Loc), + Prefix => New_Occurrence_Of (Standard_Integer, Loc), Attribute_Name => Name_Integer_Value, - Expressions => New_List ( - + Expressions => New_List ( Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Ptyp, Loc), + Prefix => New_Occurrence_Of (Ptyp, Loc), Attribute_Name => Name_First))), Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Standard_Integer, Loc), + Prefix => New_Occurrence_Of (Standard_Integer, Loc), Attribute_Name => Name_Integer_Value, - Expressions => New_List ( - + Expressions => New_List ( Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Ptyp, Loc), + Prefix => New_Occurrence_Of (Ptyp, Loc), Attribute_Name => Name_Last))))))); Analyze_And_Resolve (N, Typ); - end Mantissa; --------- -- Max -- @@ -4363,7 +4360,7 @@ package body Exp_Attr is when Attribute_Mechanism_Code => - -- We must replace the prefix i the renamed case + -- We must replace the prefix in the renamed case if Is_Entity_Name (Pref) and then Present (Alias (Entity (Pref))) @@ -4970,8 +4967,7 @@ package body Exp_Attr is -- For integer types, Pos is equivalent to a simple integer -- conversion and we rewrite it as such - when Attribute_Pos => Pos : - declare + when Attribute_Pos => Pos : declare Etyp : Entity_Id := Base_Type (Entity (Pref)); begin @@ -5023,8 +5019,7 @@ package body Exp_Attr is -- the computation up to the back end, since we don't know what layout -- will be chosen. - when Attribute_Position => Position_Attr : - declare + when Attribute_Position => Position_Attr : declare CE : constant Entity_Id := Entity (Selector_Name (Pref)); begin @@ -5067,8 +5062,7 @@ package body Exp_Attr is -- 2. For floating-point, generate call to attribute function. -- 3. For other cases, deal with constraint checking. - when Attribute_Pred => Pred : - declare + when Attribute_Pred => Pred : declare Etyp : constant Entity_Id := Base_Type (Ptyp); begin @@ -5175,117 +5169,107 @@ package body Exp_Attr is -- about complications that would other arise from X'Priority'Access, -- which is illegal, because of the lack of aliasing. - when Attribute_Priority => - declare - Call : Node_Id; - Conctyp : Entity_Id; - Object_Parm : Node_Id; - Subprg : Entity_Id; - RT_Subprg_Name : Node_Id; + when Attribute_Priority => Priority : declare + Call : Node_Id; + Conctyp : Entity_Id; + New_Itype : Entity_Id; + Object_Parm : Node_Id; + Subprg : Entity_Id; + RT_Subprg_Name : Node_Id; - begin - -- Look for the enclosing concurrent type - - Conctyp := Current_Scope; - while not Is_Concurrent_Type (Conctyp) loop - Conctyp := Scope (Conctyp); - end loop; + begin + -- Look for the enclosing concurrent type - pragma Assert (Is_Protected_Type (Conctyp)); + Conctyp := Current_Scope; + while not Is_Concurrent_Type (Conctyp) loop + Conctyp := Scope (Conctyp); + end loop; - -- Generate the actual of the call + pragma Assert (Is_Protected_Type (Conctyp)); - Subprg := Current_Scope; - while not Present (Protected_Body_Subprogram (Subprg)) loop - Subprg := Scope (Subprg); - end loop; + -- Generate the actual of the call - -- Use of 'Priority inside protected entries and barriers (in - -- both cases the type of the first formal of their expanded - -- subprogram is Address) + Subprg := Current_Scope; + while not Present (Protected_Body_Subprogram (Subprg)) loop + Subprg := Scope (Subprg); + end loop; - if Etype (First_Entity (Protected_Body_Subprogram (Subprg))) = - RTE (RE_Address) - then - declare - New_Itype : Entity_Id; + -- Use of 'Priority inside protected entries and barriers (in both + -- cases the type of the first formal of their expanded subprogram + -- is Address) - begin - -- In the expansion of protected entries the type of the - -- first formal of the Protected_Body_Subprogram is an - -- Address. In order to reference the _object component - -- we generate: + if Etype (First_Entity (Protected_Body_Subprogram (Subprg))) = + RTE (RE_Address) + then + -- In the expansion of protected entries the type of the first + -- formal of the Protected_Body_Subprogram is an Address. In order + -- to reference the _object component we generate: - -- type T is access p__ptTV; - -- freeze T [] + -- type T is access p__ptTV; + -- freeze T [] - New_Itype := Create_Itype (E_Access_Type, N); - Set_Etype (New_Itype, New_Itype); - Set_Directly_Designated_Type (New_Itype, - Corresponding_Record_Type (Conctyp)); - Freeze_Itype (New_Itype, N); + New_Itype := Create_Itype (E_Access_Type, N); + Set_Etype (New_Itype, New_Itype); + Set_Directly_Designated_Type (New_Itype, + Corresponding_Record_Type (Conctyp)); + Freeze_Itype (New_Itype, N); - -- Generate: - -- T!(O)._object'unchecked_access + -- Generate: + -- T!(O)._object'unchecked_access - Object_Parm := - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (New_Itype, - New_Occurrence_Of - (First_Entity - (Protected_Body_Subprogram (Subprg)), - Loc)), - Selector_Name => - Make_Identifier (Loc, Name_uObject)), - Attribute_Name => Name_Unchecked_Access); - end; + Object_Parm := + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (New_Itype, + New_Occurrence_Of + (First_Entity (Protected_Body_Subprogram (Subprg)), + Loc)), + Selector_Name => Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access); - -- Use of 'Priority inside a protected subprogram + -- Use of 'Priority inside a protected subprogram - else - Object_Parm := - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of - (First_Entity - (Protected_Body_Subprogram (Subprg)), - Loc), - Selector_Name => Make_Identifier (Loc, Name_uObject)), - Attribute_Name => Name_Unchecked_Access); - end if; + else + Object_Parm := + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of + (First_Entity (Protected_Body_Subprogram (Subprg)), + Loc), + Selector_Name => Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access); + end if; - -- Select the appropriate run-time subprogram + -- Select the appropriate run-time subprogram - if Number_Entries (Conctyp) = 0 then - RT_Subprg_Name := - New_Occurrence_Of (RTE (RE_Get_Ceiling), Loc); - else - RT_Subprg_Name := - New_Occurrence_Of (RTE (RO_PE_Get_Ceiling), Loc); - end if; + if Number_Entries (Conctyp) = 0 then + RT_Subprg_Name := New_Occurrence_Of (RTE (RE_Get_Ceiling), Loc); + else + RT_Subprg_Name := New_Occurrence_Of (RTE (RO_PE_Get_Ceiling), Loc); + end if; - Call := - Make_Function_Call (Loc, - Name => RT_Subprg_Name, - Parameter_Associations => New_List (Object_Parm)); + Call := + Make_Function_Call (Loc, + Name => RT_Subprg_Name, + Parameter_Associations => New_List (Object_Parm)); - Rewrite (N, Call); + Rewrite (N, Call); - -- Avoid the generation of extra checks on the pointer to the - -- protected object. + -- Avoid the generation of extra checks on the pointer to the + -- protected object. - Analyze_And_Resolve (N, Typ, Suppress => Access_Check); - end; + Analyze_And_Resolve (N, Typ, Suppress => Access_Check); + end Priority; ------------------ -- Range_Length -- ------------------ - when Attribute_Range_Length => Range_Length : begin + when Attribute_Range_Length => -- The only special processing required is for the case where -- Range_Length is applied to an enumeration type with holes. @@ -5305,25 +5289,27 @@ package body Exp_Attr is then Rewrite (N, Make_Op_Add (Loc, - Left_Opnd => + Left_Opnd => Make_Op_Subtract (Loc, - Left_Opnd => + Left_Opnd => Make_Attribute_Reference (Loc, Attribute_Name => Name_Pos, - Prefix => New_Occurrence_Of (Ptyp, Loc), - Expressions => New_List ( + Prefix => New_Occurrence_Of (Ptyp, Loc), + Expressions => New_List ( Make_Attribute_Reference (Loc, Attribute_Name => Name_Last, - Prefix => New_Occurrence_Of (Ptyp, Loc)))), + Prefix => + New_Occurrence_Of (Ptyp, Loc)))), Right_Opnd => Make_Attribute_Reference (Loc, Attribute_Name => Name_Pos, - Prefix => New_Occurrence_Of (Ptyp, Loc), - Expressions => New_List ( + Prefix => New_Occurrence_Of (Ptyp, Loc), + Expressions => New_List ( Make_Attribute_Reference (Loc, Attribute_Name => Name_First, - Prefix => New_Occurrence_Of (Ptyp, Loc))))), + Prefix => + New_Occurrence_Of (Ptyp, Loc))))), Right_Opnd => Make_Integer_Literal (Loc, 1))); @@ -5336,7 +5322,6 @@ package body Exp_Attr is else Apply_Universal_Integer_Attribute_Checks (N); end if; - end Range_Length; ---------- -- Read -- @@ -5627,241 +5612,247 @@ package body Exp_Attr is -- Size -- ---------- - when Attribute_Size | - Attribute_Object_Size | - Attribute_Value_Size | - Attribute_VADS_Size => Size : - - declare - Siz : Uint; - New_Node : Node_Id; - - begin - -- Processing for VADS_Size case. Note that this processing removes - -- all traces of VADS_Size from the tree, and completes all required - -- processing for VADS_Size by translating the attribute reference - -- to an appropriate Size or Object_Size reference. + when Attribute_Object_Size + | Attribute_Size + | Attribute_Value_Size + | Attribute_VADS_Size + => + Size : declare + Siz : Uint; + New_Node : Node_Id; - if Id = Attribute_VADS_Size - or else (Use_VADS_Size and then Id = Attribute_Size) - then - -- If the size is specified, then we simply use the specified - -- size. This applies to both types and objects. The size of an - -- object can be specified in the following ways: - - -- An explicit size object is given for an object - -- A component size is specified for an indexed component - -- A component clause is specified for a selected component - -- The object is a component of a packed composite object - - -- If the size is specified, then VADS_Size of an object - - if (Is_Entity_Name (Pref) - and then Present (Size_Clause (Entity (Pref)))) - or else - (Nkind (Pref) = N_Component_Clause - and then (Present (Component_Clause - (Entity (Selector_Name (Pref)))) - or else Is_Packed (Etype (Prefix (Pref))))) - or else - (Nkind (Pref) = N_Indexed_Component - and then (Component_Size (Etype (Prefix (Pref))) /= 0 - or else Is_Packed (Etype (Prefix (Pref))))) + begin + -- Processing for VADS_Size case. Note that this processing + -- removes all traces of VADS_Size from the tree, and completes + -- all required processing for VADS_Size by translating the + -- attribute reference to an appropriate Size or Object_Size + -- reference. + + if Id = Attribute_VADS_Size + or else (Use_VADS_Size and then Id = Attribute_Size) then - Set_Attribute_Name (N, Name_Size); + -- If the size is specified, then we simply use the specified + -- size. This applies to both types and objects. The size of an + -- object can be specified in the following ways: + + -- An explicit size object is given for an object + -- A component size is specified for an indexed component + -- A component clause is specified for a selected component + -- The object is a component of a packed composite object + + -- If the size is specified, then VADS_Size of an object + + if (Is_Entity_Name (Pref) + and then Present (Size_Clause (Entity (Pref)))) + or else + (Nkind (Pref) = N_Component_Clause + and then (Present (Component_Clause + (Entity (Selector_Name (Pref)))) + or else Is_Packed (Etype (Prefix (Pref))))) + or else + (Nkind (Pref) = N_Indexed_Component + and then (Component_Size (Etype (Prefix (Pref))) /= 0 + or else Is_Packed (Etype (Prefix (Pref))))) + then + Set_Attribute_Name (N, Name_Size); - -- Otherwise if we have an object rather than a type, then the - -- VADS_Size attribute applies to the type of the object, rather - -- than the object itself. This is one of the respects in which - -- VADS_Size differs from Size. + -- Otherwise if we have an object rather than a type, then + -- the VADS_Size attribute applies to the type of the object, + -- rather than the object itself. This is one of the respects + -- in which VADS_Size differs from Size. - else - if (not Is_Entity_Name (Pref) - or else not Is_Type (Entity (Pref))) - and then (Is_Scalar_Type (Ptyp) or else Is_Constrained (Ptyp)) - then - Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc)); - end if; + else + if (not Is_Entity_Name (Pref) + or else not Is_Type (Entity (Pref))) + and then (Is_Scalar_Type (Ptyp) + or else Is_Constrained (Ptyp)) + then + Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc)); + end if; - -- For a scalar type for which no size was explicitly given, - -- VADS_Size means Object_Size. This is the other respect in - -- which VADS_Size differs from Size. + -- For a scalar type for which no size was explicitly given, + -- VADS_Size means Object_Size. This is the other respect in + -- which VADS_Size differs from Size. - if Is_Scalar_Type (Ptyp) and then No (Size_Clause (Ptyp)) then - Set_Attribute_Name (N, Name_Object_Size); + if Is_Scalar_Type (Ptyp) + and then No (Size_Clause (Ptyp)) + then + Set_Attribute_Name (N, Name_Object_Size); - -- In all other cases, Size and VADS_Size are the sane + -- In all other cases, Size and VADS_Size are the sane - else - Set_Attribute_Name (N, Name_Size); + else + Set_Attribute_Name (N, Name_Size); + end if; end if; end if; - end if; - -- If the prefix is X'Class, we transform it into a direct reference - -- to the class-wide type, because the back end must not see a 'Class - -- reference. + -- If the prefix is X'Class, transform it into a direct reference + -- to the class-wide type, because the back end must not see a + -- 'Class reference. - if Is_Entity_Name (Pref) - and then Is_Class_Wide_Type (Entity (Pref)) - then - Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc)); - return; + if Is_Entity_Name (Pref) + and then Is_Class_Wide_Type (Entity (Pref)) + then + Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc)); + return; - -- For X'Size applied to an object of a class-wide type, transform - -- X'Size into a call to the primitive operation _Size applied to X. + -- For X'Size applied to an object of a class-wide type, transform + -- X'Size into a call to the primitive operation _Size applied to + -- X. - elsif Is_Class_Wide_Type (Ptyp) then + elsif Is_Class_Wide_Type (Ptyp) then - -- No need to do anything else compiling under restriction - -- No_Dispatching_Calls. During the semantic analysis we - -- already noted this restriction violation. + -- No need to do anything else compiling under restriction + -- No_Dispatching_Calls. During the semantic analysis we + -- already noted this restriction violation. - if Restriction_Active (No_Dispatching_Calls) then - return; - end if; + if Restriction_Active (No_Dispatching_Calls) then + return; + end if; - New_Node := - Make_Function_Call (Loc, - Name => New_Occurrence_Of - (Find_Prim_Op (Ptyp, Name_uSize), Loc), - Parameter_Associations => New_List (Pref)); + New_Node := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Find_Prim_Op (Ptyp, Name_uSize), Loc), + Parameter_Associations => New_List (Pref)); - if Typ /= Standard_Long_Long_Integer then + if Typ /= Standard_Long_Long_Integer then - -- The context is a specific integer type with which the - -- original attribute was compatible. The function has a - -- specific type as well, so to preserve the compatibility - -- we must convert explicitly. + -- The context is a specific integer type with which the + -- original attribute was compatible. The function has a + -- specific type as well, so to preserve the compatibility + -- we must convert explicitly. - New_Node := Convert_To (Typ, New_Node); - end if; + New_Node := Convert_To (Typ, New_Node); + end if; - Rewrite (N, New_Node); - Analyze_And_Resolve (N, Typ); - return; + Rewrite (N, New_Node); + Analyze_And_Resolve (N, Typ); + return; - -- Case of known RM_Size of a type + -- Case of known RM_Size of a type - elsif (Id = Attribute_Size or else Id = Attribute_Value_Size) - and then Is_Entity_Name (Pref) - and then Is_Type (Entity (Pref)) - and then Known_Static_RM_Size (Entity (Pref)) - then - Siz := RM_Size (Entity (Pref)); + elsif (Id = Attribute_Size or else Id = Attribute_Value_Size) + and then Is_Entity_Name (Pref) + and then Is_Type (Entity (Pref)) + and then Known_Static_RM_Size (Entity (Pref)) + then + Siz := RM_Size (Entity (Pref)); - -- Case of known Esize of a type + -- Case of known Esize of a type - elsif Id = Attribute_Object_Size - and then Is_Entity_Name (Pref) - and then Is_Type (Entity (Pref)) - and then Known_Static_Esize (Entity (Pref)) - then - Siz := Esize (Entity (Pref)); + elsif Id = Attribute_Object_Size + and then Is_Entity_Name (Pref) + and then Is_Type (Entity (Pref)) + and then Known_Static_Esize (Entity (Pref)) + then + Siz := Esize (Entity (Pref)); - -- Case of known size of object + -- Case of known size of object - elsif Id = Attribute_Size - and then Is_Entity_Name (Pref) - and then Is_Object (Entity (Pref)) - and then Known_Esize (Entity (Pref)) - and then Known_Static_Esize (Entity (Pref)) - then - Siz := Esize (Entity (Pref)); + elsif Id = Attribute_Size + and then Is_Entity_Name (Pref) + and then Is_Object (Entity (Pref)) + and then Known_Esize (Entity (Pref)) + and then Known_Static_Esize (Entity (Pref)) + then + Siz := Esize (Entity (Pref)); - -- For an array component, we can do Size in the front end - -- if the component_size of the array is set. + -- For an array component, we can do Size in the front end if the + -- component_size of the array is set. - elsif Nkind (Pref) = N_Indexed_Component then - Siz := Component_Size (Etype (Prefix (Pref))); + elsif Nkind (Pref) = N_Indexed_Component then + Siz := Component_Size (Etype (Prefix (Pref))); - -- For a record component, we can do Size in the front end if there - -- is a component clause, or if the record is packed and the - -- component's size is known at compile time. + -- For a record component, we can do Size in the front end if + -- there is a component clause, or if the record is packed and the + -- component's size is known at compile time. - elsif Nkind (Pref) = N_Selected_Component then - declare - Rec : constant Entity_Id := Etype (Prefix (Pref)); - Comp : constant Entity_Id := Entity (Selector_Name (Pref)); + elsif Nkind (Pref) = N_Selected_Component then + declare + Rec : constant Entity_Id := Etype (Prefix (Pref)); + Comp : constant Entity_Id := Entity (Selector_Name (Pref)); - begin - if Present (Component_Clause (Comp)) then - Siz := Esize (Comp); + begin + if Present (Component_Clause (Comp)) then + Siz := Esize (Comp); - elsif Is_Packed (Rec) then - Siz := RM_Size (Ptyp); + elsif Is_Packed (Rec) then + Siz := RM_Size (Ptyp); - else - Apply_Universal_Integer_Attribute_Checks (N); - return; - end if; - end; + else + Apply_Universal_Integer_Attribute_Checks (N); + return; + end if; + end; - -- All other cases are handled by the back end + -- All other cases are handled by the back end - else - Apply_Universal_Integer_Attribute_Checks (N); + else + Apply_Universal_Integer_Attribute_Checks (N); - -- If Size is applied to a formal parameter that is of a packed - -- array subtype, then apply Size to the actual subtype. + -- If Size is applied to a formal parameter that is of a packed + -- array subtype, then apply Size to the actual subtype. - if Is_Entity_Name (Pref) - and then Is_Formal (Entity (Pref)) - and then Is_Array_Type (Ptyp) - and then Is_Packed (Ptyp) - then - Rewrite (N, - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc), - Attribute_Name => Name_Size)); - Analyze_And_Resolve (N, Typ); - end if; + if Is_Entity_Name (Pref) + and then Is_Formal (Entity (Pref)) + and then Is_Array_Type (Ptyp) + and then Is_Packed (Ptyp) + then + Rewrite (N, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc), + Attribute_Name => Name_Size)); + Analyze_And_Resolve (N, Typ); + end if; - -- If Size applies to a dereference of an access to unconstrained - -- packed array, the back end needs to see its unconstrained - -- nominal type, but also a hint to the actual constrained type. + -- If Size applies to a dereference of an access to + -- unconstrained packed array, the back end needs to see its + -- unconstrained nominal type, but also a hint to the actual + -- constrained type. - if Nkind (Pref) = N_Explicit_Dereference - and then Is_Array_Type (Ptyp) - and then not Is_Constrained (Ptyp) - and then Is_Packed (Ptyp) - then - Set_Actual_Designated_Subtype (Pref, - Get_Actual_Subtype (Pref)); - end if; + if Nkind (Pref) = N_Explicit_Dereference + and then Is_Array_Type (Ptyp) + and then not Is_Constrained (Ptyp) + and then Is_Packed (Ptyp) + then + Set_Actual_Designated_Subtype (Pref, + Get_Actual_Subtype (Pref)); + end if; - return; - end if; + return; + end if; - -- Common processing for record and array component case + -- Common processing for record and array component case - if Siz /= No_Uint and then Siz /= 0 then - declare - CS : constant Boolean := Comes_From_Source (N); + if Siz /= No_Uint and then Siz /= 0 then + declare + CS : constant Boolean := Comes_From_Source (N); - begin - Rewrite (N, Make_Integer_Literal (Loc, Siz)); + begin + Rewrite (N, Make_Integer_Literal (Loc, Siz)); - -- This integer literal is not a static expression. We do not - -- call Analyze_And_Resolve here, because this would activate - -- the circuit for deciding that a static value was out of - -- range, and we don't want that. + -- This integer literal is not a static expression. We do + -- not call Analyze_And_Resolve here, because this would + -- activate the circuit for deciding that a static value + -- was out of range, and we don't want that. - -- So just manually set the type, mark the expression as non- - -- static, and then ensure that the result is checked properly - -- if the attribute comes from source (if it was internally - -- generated, we never need a constraint check). + -- So just manually set the type, mark the expression as + -- non-static, and then ensure that the result is checked + -- properly if the attribute comes from source (if it was + -- internally generated, we never need a constraint check). - Set_Etype (N, Typ); - Set_Is_Static_Expression (N, False); + Set_Etype (N, Typ); + Set_Is_Static_Expression (N, False); - if CS then - Apply_Constraint_Check (N, Typ); - end if; - end; - end if; - end Size; + if CS then + Apply_Constraint_Check (N, Typ); + end if; + end; + end if; + end Size; ------------------ -- Storage_Pool -- @@ -6071,7 +6062,6 @@ package body Exp_Attr is Etyp : constant Entity_Id := Base_Type (Ptyp); begin - -- For enumeration types with non-standard representations, we -- expand typ'Succ (x) into @@ -6241,8 +6231,8 @@ package body Exp_Attr is -- Transforms 'Terminated attribute into a call to Terminated function - when Attribute_Terminated => Terminated : - begin + when Attribute_Terminated => Terminated : begin + -- The prefix of Terminated is of a task interface class-wide type. -- Generate: -- terminated (Task_Id (Pref._disp_get_task_id)); @@ -6286,7 +6276,9 @@ package body Exp_Attr is -- Transforms System'To_Address (X) and System.Address'Ref (X) into -- unchecked conversion from (integral) type of X to type address. - when Attribute_To_Address | Attribute_Ref => + when Attribute_Ref + | Attribute_To_Address + => Rewrite (N, Unchecked_Convert_To (RTE (RE_Address), Relocate_Node (First (Exprs)))); @@ -6973,8 +6965,7 @@ package body Exp_Attr is -- is in use such as Shift-JIS, then characters that cannot be -- represented using this encoding will not appear in any case. - when Attribute_Wide_Value => Wide_Value : - begin + when Attribute_Wide_Value => Rewrite (N, Make_Attribute_Reference (Loc, Prefix => Pref, @@ -6991,7 +6982,6 @@ package body Exp_Attr is Intval => Int (Wide_Character_Encoding_Method))))))); Analyze_And_Resolve (N, Typ); - end Wide_Value; --------------------- -- Wide_Wide_Value -- @@ -7011,8 +7001,7 @@ package body Exp_Attr is -- It's not quite right where typ = Wide_Wide_Character, because the -- encoding method may not cover the whole character type ??? - when Attribute_Wide_Wide_Value => Wide_Wide_Value : - begin + when Attribute_Wide_Wide_Value => Rewrite (N, Make_Attribute_Reference (Loc, Prefix => Pref, @@ -7020,7 +7009,7 @@ package body Exp_Attr is Expressions => New_List ( Make_Function_Call (Loc, - Name => + Name => New_Occurrence_Of (RTE (RE_Wide_Wide_String_To_String), Loc), @@ -7030,7 +7019,6 @@ package body Exp_Attr is Intval => Int (Wide_Character_Encoding_Method))))))); Analyze_And_Resolve (N, Typ); - end Wide_Wide_Value; --------------------- -- Wide_Wide_Width -- @@ -7213,92 +7201,96 @@ package body Exp_Attr is -- The back end also handles the non-class-wide cases of Size - when Attribute_Bit_Order | - Attribute_Code_Address | - Attribute_Definite | - Attribute_Deref | - Attribute_Null_Parameter | - Attribute_Passed_By_Reference | - Attribute_Pool_Address | - Attribute_Scalar_Storage_Order => + when Attribute_Bit_Order + | Attribute_Code_Address + | Attribute_Definite + | Attribute_Deref + | Attribute_Null_Parameter + | Attribute_Passed_By_Reference + | Attribute_Pool_Address + | Attribute_Scalar_Storage_Order + => null; -- The following attributes are also handled by the back end, but return -- a universal integer result, so may need a conversion for checking -- that the result is in range. - when Attribute_Aft | - Attribute_Max_Alignment_For_Allocation => + when Attribute_Aft + | Attribute_Max_Alignment_For_Allocation + => Apply_Universal_Integer_Attribute_Checks (N); -- The following attributes should not appear at this stage, since they -- have already been handled by the analyzer (and properly rewritten -- with corresponding values or entities to represent the right values) - when Attribute_Abort_Signal | - Attribute_Address_Size | - Attribute_Atomic_Always_Lock_Free | - Attribute_Base | - Attribute_Class | - Attribute_Compiler_Version | - Attribute_Default_Bit_Order | - Attribute_Default_Scalar_Storage_Order | - Attribute_Delta | - Attribute_Denorm | - Attribute_Digits | - Attribute_Emax | - Attribute_Enabled | - Attribute_Epsilon | - Attribute_Fast_Math | - Attribute_First_Valid | - Attribute_Has_Access_Values | - Attribute_Has_Discriminants | - Attribute_Has_Tagged_Values | - Attribute_Large | - Attribute_Last_Valid | - Attribute_Library_Level | - Attribute_Lock_Free | - Attribute_Machine_Emax | - Attribute_Machine_Emin | - Attribute_Machine_Mantissa | - Attribute_Machine_Overflows | - Attribute_Machine_Radix | - Attribute_Machine_Rounds | - Attribute_Maximum_Alignment | - Attribute_Model_Emin | - Attribute_Model_Epsilon | - Attribute_Model_Mantissa | - Attribute_Model_Small | - Attribute_Modulus | - Attribute_Partition_ID | - Attribute_Range | - Attribute_Restriction_Set | - Attribute_Safe_Emax | - Attribute_Safe_First | - Attribute_Safe_Large | - Attribute_Safe_Last | - Attribute_Safe_Small | - Attribute_Scale | - Attribute_Signed_Zeros | - Attribute_Small | - Attribute_Storage_Unit | - Attribute_Stub_Type | - Attribute_System_Allocator_Alignment | - Attribute_Target_Name | - Attribute_Type_Class | - Attribute_Type_Key | - Attribute_Unconstrained_Array | - Attribute_Universal_Literal_String | - Attribute_Wchar_T_Size | - Attribute_Word_Size => + when Attribute_Abort_Signal + | Attribute_Address_Size + | Attribute_Atomic_Always_Lock_Free + | Attribute_Base + | Attribute_Class + | Attribute_Compiler_Version + | Attribute_Default_Bit_Order + | Attribute_Default_Scalar_Storage_Order + | Attribute_Delta + | Attribute_Denorm + | Attribute_Digits + | Attribute_Emax + | Attribute_Enabled + | Attribute_Epsilon + | Attribute_Fast_Math + | Attribute_First_Valid + | Attribute_Has_Access_Values + | Attribute_Has_Discriminants + | Attribute_Has_Tagged_Values + | Attribute_Large + | Attribute_Last_Valid + | Attribute_Library_Level + | Attribute_Lock_Free + | Attribute_Machine_Emax + | Attribute_Machine_Emin + | Attribute_Machine_Mantissa + | Attribute_Machine_Overflows + | Attribute_Machine_Radix + | Attribute_Machine_Rounds + | Attribute_Maximum_Alignment + | Attribute_Model_Emin + | Attribute_Model_Epsilon + | Attribute_Model_Mantissa + | Attribute_Model_Small + | Attribute_Modulus + | Attribute_Partition_ID + | Attribute_Range + | Attribute_Restriction_Set + | Attribute_Safe_Emax + | Attribute_Safe_First + | Attribute_Safe_Large + | Attribute_Safe_Last + | Attribute_Safe_Small + | Attribute_Scale + | Attribute_Signed_Zeros + | Attribute_Small + | Attribute_Storage_Unit + | Attribute_Stub_Type + | Attribute_System_Allocator_Alignment + | Attribute_Target_Name + | Attribute_Type_Class + | Attribute_Type_Key + | Attribute_Unconstrained_Array + | Attribute_Universal_Literal_String + | Attribute_Wchar_T_Size + | Attribute_Word_Size + => raise Program_Error; -- The Asm_Input and Asm_Output attributes are not expanded at this -- stage, but will be eliminated in the expansion of the Asm call, see -- Exp_Intr for details. So the back end will never see these either. - when Attribute_Asm_Input | - Attribute_Asm_Output => + when Attribute_Asm_Input + | Attribute_Asm_Output + => null; end case; diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 1c170e210b4..0e0bbca440e 100644 --- a/gcc/ada/exp_ch13.adb +++ b/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; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 3fafb9ca218..e6879a3c358 100644 --- a/gcc/ada/exp_ch3.adb +++ b/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; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 82419259d66..b89d66c03f8 100644 --- a/gcc/ada/exp_ch4.adb +++ b/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_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; - - 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_Le => - True_Result := Res in Compare_LE; - False_Result := Res = GT; + 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; + + 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 = 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_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_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; - 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 diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index ffe4b5cfbdc..c372a726cf0 100644 --- a/gcc/ada/exp_ch5.adb +++ b/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; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 04122e35f16..7c629f84693 100644 --- a/gcc/ada/exp_ch6.adb +++ b/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; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 131df4a72ac..c9b487083d6 100644 --- a/gcc/ada/exp_ch7.adb +++ b/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 => diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 8ca30b3c370..7cae0e5581f 100644 --- a/gcc/ada/exp_ch9.adb +++ b/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; diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index 71454509216..4064e32fa04 100644 --- a/gcc/ada/exp_dbug.adb +++ b/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; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 770cb0fa694..d2ddb5e62e8 100644 --- a/gcc/ada/exp_disp.adb +++ b/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 => diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 635b2ff976f..5af01bcd778 100644 --- a/gcc/ada/exp_dist.adb +++ b/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); diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index e4d45d5f09d..3d0934c8d69 100644 --- a/gcc/ada/exp_intr.adb +++ b/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 diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 858c632275e..e2a6753003e 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -215,7 +215,6 @@ package body Exp_Prag is when others => null; end case; - end Expand_N_Pragma; ------------------------------- diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb index 6b355aa99c0..5b002ca86ee 100644 --- a/gcc/ada/exp_spark.adb +++ b/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 => diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index e8654bc0954..9ba997a589a 100644 --- a/gcc/ada/exp_util.adb +++ b/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,22 +5681,21 @@ 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; + 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; + return; - -- In the subexpression case, keep climbing + -- In the subexpression case, keep climbing - else - null; - end if; + else + null; + end if; -- If a component association appears within a loop created for -- an array aggregate, attach the actions to the association so @@ -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,22 +5755,21 @@ 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; + 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; + return; - -- In the subexpression case, keep climbing + -- In the subexpression case, keep climbing - else - null; - end if; + else + null; + end if; -- A contract node should not belong to the tree @@ -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 diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb index 8bd95e301a5..9045b6a72b7 100644 --- a/gcc/ada/expander.adb +++ b/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; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 8215a7602c3..81524c1f4d1 100644 --- a/gcc/ada/freeze.adb +++ b/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 diff --git a/gcc/ada/g-arrspl.adb b/gcc/ada/g-arrspl.adb index 2984bb8ed67..f3eaf809f97 100644 --- a/gcc/ada/g-arrspl.adb +++ b/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; diff --git a/gcc/ada/g-awk.adb b/gcc/ada/g-awk.adb index 6f58e46a584..5771100b678 100644 --- a/gcc/ada/g-awk.adb +++ b/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; diff --git a/gcc/ada/g-catiio.adb b/gcc/ada/g-catiio.adb index c0ccb4b7961..772a70b8839 100644 --- a/gcc/ada/g-catiio.adb +++ b/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 diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb index 5260fec3bd9..ef76fee3f68 100644 --- a/gcc/ada/g-comlin.adb +++ b/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; diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb index f7d3c2df70e..89de4d6183a 100644 --- a/gcc/ada/g-debpoo.adb +++ b/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); diff --git a/gcc/ada/g-expect.adb b/gcc/ada/g-expect.adb index d7e65fb3e45..d7bb2dda378 100644 --- a/gcc/ada/g-expect.adb +++ b/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. diff --git a/gcc/ada/g-forstr.adb b/gcc/ada/g-forstr.adb index a6ebc919303..5652c111791 100644 --- a/gcc/ada/g-forstr.adb +++ b/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 diff --git a/gcc/ada/g-memdum.adb b/gcc/ada/g-memdum.adb index 8aa24a72c79..bee7991ce64 100644 --- a/gcc/ada/g-memdum.adb +++ b/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; diff --git a/gcc/ada/g-pehage.adb b/gcc/ada/g-pehage.adb index 81370117fc0..76ecb02356f 100644 --- a/gcc/ada/g-pehage.adb +++ b/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; diff --git a/gcc/ada/g-sercom-linux.adb b/gcc/ada/g-sercom-linux.adb index f12d6ac2a23..4140106c8d6 100644 --- a/gcc/ada/g-sercom-linux.adb +++ b/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; diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index 29ede344b04..a8b718a511a 100644 --- a/gcc/ada/g-socket.adb +++ b/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 diff --git a/gcc/ada/g-socthi-mingw.adb b/gcc/ada/g-socthi-mingw.adb index f35239c28e6..6ce2fb6cc42 100644 --- a/gcc/ada/g-socthi-mingw.adb +++ b/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); diff --git a/gcc/ada/g-spipat.adb b/gcc/ada/g-spipat.adb index 065e37dfdd1..348c8e4e00a 100644 --- a/gcc/ada/g-spipat.adb +++ b/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_Alt + | PC_Arb_X + | PC_Arbno_S + | PC_Arbno_X + => + Alt : PE_Ptr; - 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_Rpat => PP : Pattern_Ptr; - - 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_Write_Imm | - PC_Write_OnM => FP : File_Ptr; - - when PC_String => Str : String_Ptr; - - when PC_String_2 => Str2 : String (1 .. 2); - - when PC_String_3 => Str3 : String (1 .. 3); - - when PC_String_4 => Str4 : String (1 .. 4); - - when PC_String_5 => Str5 : String (1 .. 5); - - when PC_String_6 => Str6 : String (1 .. 6); - - 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_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_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_Rpat => + PP : Pattern_Ptr; + + 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_Write_Imm + | PC_Write_OnM + => + FP : File_Ptr; + + when PC_String => + Str : String_Ptr; + + when PC_String_2 => + Str2 : String (1 .. 2); + + when PC_String_3 => + Str3 : String (1 .. 3); + + when PC_String_4 => + Str4 : String (1 .. 4); + when PC_String_5 => + Str5 : String (1 .. 5); + + when PC_String_6 => + Str6 : String (1 .. 6); + + 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_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_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; 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 diff --git a/gcc/ada/get_scos.adb b/gcc/ada/get_scos.adb index 48c9c463217..79e0a954883 100644 --- a/gcc/ada/get_scos.adb +++ b/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 diff --git a/gcc/ada/get_spark_xrefs.adb b/gcc/ada/get_spark_xrefs.adb index 63474ee8742..9b82d5bfdd1 100644 --- a/gcc/ada/get_spark_xrefs.adb +++ b/gcc/ada/get_spark_xrefs.adb @@ -412,7 +412,6 @@ begin -- Loop through cross-references for this entity loop - declare Line : Nat; Col : Nat; diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index a2e6e897b74..34aea34f06b 100644 --- a/gcc/ada/gnat1drv.adb +++ b/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 => diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index 8cd99cf8f75..7d9875173cc 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -277,7 +277,6 @@ procedure Gnatbind is when others => raise Program_Error; - end case; end Restriction_Could_Be_Set; diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 9a04e78abec..e82e8d591ae 100644 --- a/gcc/ada/gnatcmd.adb +++ b/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; diff --git a/gcc/ada/gnatdll.adb b/gcc/ada/gnatdll.adb index 426c00f58bd..94b39b8cc7d 100644 --- a/gcc/ada/gnatdll.adb +++ b/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; diff --git a/gcc/ada/gprep.adb b/gcc/ada/gprep.adb index c4bf8e91a52..666d0ae2dcd 100644 --- a/gcc/ada/gprep.adb +++ b/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; diff --git a/gcc/ada/i-cobol.adb b/gcc/ada/i-cobol.adb index ed5b0ab6a37..bd331b48c92 100644 --- a/gcc/ada/i-cobol.adb +++ b/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; diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index 7e28d3f43b0..4373a970ec4 100644 --- a/gcc/ada/layout.adb +++ b/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 - - when Dynamic | Discrim => - Nod : Node_Id; - -- Expression value so far if Val_Status /= Const - - end case; - end record; + 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 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 diff --git a/gcc/ada/lib-xref-spark_specific.adb b/gcc/ada/lib-xref-spark_specific.adb index 87d3942cbdf..b74489fb34d 100644 --- a/gcc/ada/lib-xref-spark_specific.adb +++ b/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 => diff --git a/gcc/ada/live.adb b/gcc/ada/live.adb index 4a75b9884c6..0c09609ea7d 100644 --- a/gcc/ada/live.adb +++ b/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 diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index a782958b802..4fd741c1be6 100644 --- a/gcc/ada/make.adb +++ b/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 => diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index 997cbf003ac..53233a02e30 100644 --- a/gcc/ada/makeutl.adb +++ b/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; diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index 97797b468e3..d830b668378 100644 --- a/gcc/ada/mlib-prj.adb +++ b/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, diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index d1e4f644402..8c6c22b9d14 100644 --- a/gcc/ada/osint.adb +++ b/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; diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb index cd1f91a0788..52f687ee03d 100644 --- a/gcc/ada/par-ch12.adb +++ b/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; diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index b7ab2ad3534..4dda2980c80 100644 --- a/gcc/ada/par-ch3.adb +++ b/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. diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 64402a598d3..7bbd48b2dc0 100644 --- a/gcc/ada/par-ch4.adb +++ b/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; diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb index 1aecca6b12d..5d8b45ceae5 100644 --- a/gcc/ada/par-ch5.adb +++ b/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; -------------------- diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index ac829ad19ad..0046badb39f 100644 --- a/gcc/ada/par-prag.adb +++ b/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; -------------------- diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index 6bdea984374..4815cf0ba41 100644 --- a/gcc/ada/par_sco.adb +++ b/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); - when others => - - -- All other cases of compilation units (e.g. renamings), generate - -- no SCO information. + -- All other cases of compilation units (e.g. renamings), generate no + -- SCO information. + when others => 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; diff --git a/gcc/ada/pprint.adb b/gcc/ada/pprint.adb index c520cf56116..fcfccd316f8 100644 --- a/gcc/ada/pprint.adb +++ b/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; + 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 + -- CR/LF/FF is the end of any comment - when ASCII.LF | ASCII.CR | ASCII.FF => - Skipping_Comment := False; + when ASCII.CR + | ASCII.FF + | ASCII.LF + => + Skipping_Comment := False; - when others => - Underscore := False; + when others => + Underscore := False; - if not Skipping_Comment then + if not Skipping_Comment then - -- Ignore comment + -- Ignore comment - if Src (Scn) = '-' and then Src (Scn + 1) = '-' then - Skipping_Comment := True; + if Src (Scn) = '-' and then Src (Scn + 1) = '-' then + Skipping_Comment := True; - else - Index := Index + 1; - Buffer (Index) := Src (Scn); + else + Index := Index + 1; + Buffer (Index) := Src (Scn); + end if; end if; - end if; end case; Scn := Scn + 1; diff --git a/gcc/ada/prep.adb b/gcc/ada/prep.adb index 6f401ede478..02256ec66c0 100644 --- a/gcc/ada/prep.adb +++ b/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; diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb index 204e577c820..9c9472cc61e 100644 --- a/gcc/ada/prj-dect.adb +++ b/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"); + + 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 others => - Error_Msg (Flags, "index not allowed here", Token_Ptr); - Scan (In_Tree); + Scan (In_Tree); + end if; - if Token = Tok_Integer_Literal then + 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 => diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index 92019fcda9c..18741be7917 100644 --- a/gcc/ada/prj-env.adb +++ b/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; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index fb8ce27080a..a224e7d0384 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/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; diff --git a/gcc/ada/prj-pp.adb b/gcc/ada/prj-pp.adb index 2b05eaadefb..6da5ae2325d 100644 --- a/gcc/ada/prj-pp.adb +++ b/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; diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index 3a014f1f6b3..ff68ce79b6b 100644 --- a/gcc/ada/prj-proc.adb +++ b/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 => diff --git a/gcc/ada/prj-strt.adb b/gcc/ada/prj-strt.adb index 8956e97a149..eb7aaa3f4df 100644 --- a/gcc/ada/prj-strt.adb +++ b/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, diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb index 75def1c06ef..ea852d110c7 100644 --- a/gcc/ada/prj-tree.adb +++ b/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 diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 35226dba112..e14f63e7feb 100644 --- a/gcc/ada/prj.adb +++ b/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; diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index 77636ec1c57..90bb6dacc23 100644 --- a/gcc/ada/repinfo.adb +++ b/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; diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index d6e76cfbe28..3b078c2e660 100644 --- a/gcc/ada/rtsfind.adb +++ b/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; -------------------- diff --git a/gcc/ada/s-exctra.adb b/gcc/ada/s-exctra.adb index 1d6cabfcc82..343a723b67d 100644 --- a/gcc/ada/s-exctra.adb +++ b/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; diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb index b8bc1ad2248..9c27a0e9072 100644 --- a/gcc/ada/s-fileio.adb +++ b/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; diff --git a/gcc/ada/s-interr.adb b/gcc/ada/s-interr.adb index 3c988af5a02..a88b643784f 100644 --- a/gcc/ada/s-interr.adb +++ b/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. diff --git a/gcc/ada/s-intman-android.adb b/gcc/ada/s-intman-android.adb index 2822cbd4cf8..6c8f0fbe1d4 100644 --- a/gcc/ada/s-intman-android.adb +++ b/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; diff --git a/gcc/ada/s-intman-posix.adb b/gcc/ada/s-intman-posix.adb index 7cf08c8b88a..92e7ab156b9 100644 --- a/gcc/ada/s-intman-posix.adb +++ b/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; diff --git a/gcc/ada/s-intman-solaris.adb b/gcc/ada/s-intman-solaris.adb index 170cd82f8da..03366b90189 100644 --- a/gcc/ada/s-intman-solaris.adb +++ b/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; diff --git a/gcc/ada/s-io.adb b/gcc/ada/s-io.adb index 4925471ff96..d8fd5f51c4f 100644 --- a/gcc/ada/s-io.adb +++ b/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; diff --git a/gcc/ada/s-osprim-mingw.adb b/gcc/ada/s-osprim-mingw.adb index 9f7af90c521..6d4f2bf242a 100644 --- a/gcc/ada/s-osprim-mingw.adb +++ b/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; diff --git a/gcc/ada/s-regexp.adb b/gcc/ada/s-regexp.adb index e9faa1cc6b2..8324504168f 100644 --- a/gcc/ada/s-regexp.adb +++ b/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 diff --git a/gcc/ada/s-tasini.adb b/gcc/ada/s-tasini.adb index dddad762e34..48444431c52 100644 --- a/gcc/ada/s-tasini.adb +++ b/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; diff --git a/gcc/ada/s-tfsetr-default.adb b/gcc/ada/s-tfsetr-default.adb index acddbefef0d..754507130b6 100644 --- a/gcc/ada/s-tfsetr-default.adb +++ b/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 => diff --git a/gcc/ada/s-tfsetr-vxworks.adb b/gcc/ada/s-tfsetr-vxworks.adb index ad7bf036296..cb57b5e00e1 100644 --- a/gcc/ada/s-tfsetr-vxworks.adb +++ b/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); diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb index 3a884c5d894..379ec41dfec 100644 --- a/gcc/ada/s-tpobop.adb +++ b/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; diff --git a/gcc/ada/s-tratas-default.adb b/gcc/ada/s-tratas-default.adb index 24f0d248182..9e45771bd09 100644 --- a/gcc/ada/s-tratas-default.adb +++ b/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:"; diff --git a/gcc/ada/s-wchcnv.adb b/gcc/ada/s-wchcnv.adb index 345af8f57d7..7e2ab08e55b 100644 --- a/gcc/ada/s-wchcnv.adb +++ b/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)); diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index f0a9013a8b8..3e2d7fa03fa 100644 --- a/gcc/ada/scng.adb +++ b/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; diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 74d77ab2490..f06f6845748 100644 --- a/gcc/ada/sem.adb +++ b/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. diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index be2fd901940..8630554d988 100644 --- a/gcc/ada/sem_aggr.adb +++ b/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 => diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index dcb32867a3a..5c244eed70b 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -2946,12 +2946,13 @@ package body Sem_Attr is -- Attributes related to Ada 2012 iterators. Attribute specifications -- exist for these, but they cannot be queried. - when Attribute_Constant_Indexing | - Attribute_Default_Iterator | - Attribute_Implicit_Dereference | - Attribute_Iterator_Element | - Attribute_Iterable | - Attribute_Variable_Indexing => + when Attribute_Constant_Indexing + | Attribute_Default_Iterator + | Attribute_Implicit_Dereference + | Attribute_Iterator_Element + | Attribute_Iterable + | Attribute_Variable_Indexing + => Error_Msg_N ("illegal attribute", N); -- Internal attributes used to deal with Ada 2012 delayed aspects. These @@ -3122,8 +3123,7 @@ package body Sem_Attr is -- Bit -- --------- - when Attribute_Bit => Bit : - begin + when Attribute_Bit => Check_E0; if not Is_Object_Reference (P) then @@ -3136,14 +3136,12 @@ package body Sem_Attr is end if; Set_Etype (N, Universal_Integer); - end Bit; --------------- -- Bit_Order -- --------------- - when Attribute_Bit_Order => Bit_Order : - begin + when Attribute_Bit_Order => Check_E0; Check_Type; @@ -3165,7 +3163,6 @@ package body Sem_Attr is -- Reset incorrect indication of staticness Set_Is_Static_Expression (N, False); - end Bit_Order; ------------------ -- Bit_Position -- @@ -3357,8 +3354,8 @@ package body Sem_Attr is if Warn_On_Obsolescent_Feature then Error_Msg_N - ("constrained for private type is an " & - "obsolescent feature (RM J.4)?j?", N); + ("constrained for private type is an obsolescent feature " + & "(RM J.4)?j?", N); end if; -- If we are within an instance, the attribute must be legal @@ -3450,8 +3447,7 @@ package body Sem_Attr is -- Count -- ----------- - when Attribute_Count => Count : - declare + when Attribute_Count => Count : declare Ent : Entity_Id; S : Entity_Id; Tsk : Entity_Id; @@ -3525,8 +3521,10 @@ package body Sem_Attr is exit; elsif Ekind (Scope (Ent)) in Task_Kind - and then - not Ekind_In (S, E_Loop, E_Block, E_Entry, E_Entry_Family) + and then not Ekind_In (S, E_Block, + E_Entry, + E_Entry_Family, + E_Loop) then Error_Attr ("Attribute % cannot appear in inner unit", N); @@ -3692,10 +3690,10 @@ package body Sem_Attr is -- Also handles processing for Elab_Spec and Elab_Subp_Body - when Attribute_Elab_Body | - Attribute_Elab_Spec | - Attribute_Elab_Subp_Body => - + when Attribute_Elab_Body + | Attribute_Elab_Spec + | Attribute_Elab_Subp_Body + => Check_E0; Check_Unit_Name (P); Set_Etype (N, Standard_Void_Type); @@ -3755,8 +3753,7 @@ package body Sem_Attr is -- Enum_Rep -- -------------- - when Attribute_Enum_Rep => Enum_Rep : declare - begin + when Attribute_Enum_Rep => if Present (E1) then Check_E1; Check_Discrete_Type; @@ -3767,13 +3764,12 @@ package body Sem_Attr is end if; Set_Etype (N, Universal_Integer); - end Enum_Rep; -------------- -- Enum_Val -- -------------- - when Attribute_Enum_Val => Enum_Val : begin + when Attribute_Enum_Val => Check_E1; Check_Type; @@ -3799,7 +3795,6 @@ package body Sem_Attr is Resolve (E1, Any_Integer); Set_Etype (N, P_Base_Type); end if; - end Enum_Val; ------------- -- Epsilon -- @@ -4013,8 +4008,8 @@ package body Sem_Attr is else if Ada_Version >= Ada_2005 then Error_Attr_P - ("prefix of % attribute must be an exception, a " & - "task or a task interface class-wide object"); + ("prefix of % attribute must be an exception, a task or a " + & "task interface class-wide object"); else Error_Attr_P ("prefix of % attribute must be a task or an exception"); @@ -4025,7 +4020,7 @@ package body Sem_Attr is -- Image -- ----------- - when Attribute_Image => Image : begin + when Attribute_Image => Check_SPARK_05_Restriction_On_Attribute; -- AI12-00124-1 : The ARG has adopted the GNAT semantics of 'Img @@ -4077,14 +4072,12 @@ package body Sem_Attr is then Check_Restriction (No_Fixed_IO, P); end if; - end Image; --------- -- Img -- --------- - when Attribute_Img => Img : - begin + when Attribute_Img => Check_E0; Set_Etype (N, Standard_String); @@ -4104,7 +4097,6 @@ package body Sem_Attr is then Check_Restriction (No_Fixed_IO, P); end if; - end Img; ----------- -- Input -- @@ -5100,8 +5092,7 @@ package body Sem_Attr is -- Partition_ID -- ------------------ - when Attribute_Partition_ID => Partition_Id : - begin + when Attribute_Partition_ID => Check_E0; if P_Type /= Any_Type then @@ -5120,7 +5111,6 @@ package body Sem_Attr is end if; Set_Etype (N, Universal_Integer); - end Partition_Id; ------------------------- -- Passed_By_Reference -- @@ -5680,8 +5670,7 @@ package body Sem_Attr is -- Scalar_Storage_Order -- -------------------------- - when Attribute_Scalar_Storage_Order => Scalar_Storage_Order : - declare + when Attribute_Scalar_Storage_Order => Scalar_Storage_Order : declare Ent : Entity_Id := Empty; begin @@ -5757,8 +5746,9 @@ package body Sem_Attr is -- Size -- ---------- - when Attribute_Size | Attribute_VADS_Size => Size : - begin + when Attribute_Size + | Attribute_VADS_Size + => Check_E0; -- If prefix is parameterless function call, rewrite and resolve @@ -5821,7 +5811,6 @@ package body Sem_Attr is Rewrite (N, Make_Integer_Literal (Sloc (N), Esize (Entity (P)))); Analyze (N); end if; - end Size; ----------- -- Small -- @@ -5836,9 +5825,9 @@ package body Sem_Attr is -- Storage_Pool -- ------------------ - when Attribute_Storage_Pool | - Attribute_Simple_Storage_Pool => Storage_Pool : - begin + when Attribute_Storage_Pool + | Attribute_Simple_Storage_Pool + => Check_E0; if Is_Access_Type (P_Type) then @@ -5861,8 +5850,9 @@ package body Sem_Attr is then Error_Msg_Name_1 := Aname; Error_Msg_Warn := SPARK_Mode /= On; - Error_Msg_N ("cannot use % attribute for type with simple " - & "storage pool<<", N); + Error_Msg_N + ("cannot use % attribute for type with simple storage " + & "pool<<", N); Error_Msg_N ("\Program_Error [<<", N); Rewrite @@ -5897,14 +5887,12 @@ package body Sem_Attr is else Error_Attr_P ("prefix of % attribute must be access type"); end if; - end Storage_Pool; ------------------ -- Storage_Size -- ------------------ - when Attribute_Storage_Size => Storage_Size : - begin + when Attribute_Storage_Size => Check_E0; if Is_Task_Type (P_Type) then @@ -5943,7 +5931,6 @@ package body Sem_Attr is else Error_Attr_P ("prefix of % attribute must be access or task type"); end if; - end Storage_Size; ------------------ -- Storage_Unit -- @@ -6052,8 +6039,7 @@ package body Sem_Attr is -- Tag -- --------- - when Attribute_Tag => Tag : - begin + when Attribute_Tag => Check_E0; Check_Dereference; @@ -6083,7 +6069,6 @@ package body Sem_Attr is -- Set appropriate type Set_Etype (N, RTE (RE_Tag)); - end Tag; ----------------- -- Target_Name -- @@ -6401,8 +6386,7 @@ package body Sem_Attr is -- the literal as it appeared in the source program with a possible -- leading minus sign. - when Attribute_Universal_Literal_String => Universal_Literal_String : - begin + when Attribute_Universal_Literal_String => Check_E0; if not Is_Entity_Name (P) @@ -6456,7 +6440,6 @@ package body Sem_Attr is Set_Is_Static_Expression (N, True); end; end if; - end Universal_Literal_String; ------------------------- -- Unrestricted_Access -- @@ -6809,8 +6792,7 @@ package body Sem_Attr is -- Val -- --------- - when Attribute_Val => Val : declare - begin + when Attribute_Val => Check_E1; Check_Discrete_Type; @@ -6821,13 +6803,12 @@ package body Sem_Attr is ("attribute% is not allowed for type%", P); end if; - Resolve (E1, Any_Integer); - Set_Etype (N, P_Base_Type); - -- Note, we need a range check in general, but we wait for the -- Resolve call to do this, since we want to let Eval_Attribute -- have a chance to find an static illegality first. - end Val; + + Resolve (E1, Any_Integer); + Set_Etype (N, P_Base_Type); ----------- -- Valid -- @@ -6894,8 +6875,7 @@ package body Sem_Attr is -- Value -- ----------- - when Attribute_Value => Value : - begin + when Attribute_Value => Check_SPARK_05_Restriction_On_Attribute; Check_E1; Check_Scalar_Type; @@ -6941,7 +6921,6 @@ package body Sem_Attr is then Check_Restriction (No_Fixed_IO, P); end if; - end Value; ---------------- -- Value_Size -- @@ -6973,8 +6952,7 @@ package body Sem_Attr is -- Wide_Image -- ---------------- - when Attribute_Wide_Image => Wide_Image : - begin + when Attribute_Wide_Image => Check_SPARK_05_Restriction_On_Attribute; Check_Scalar_Type; Set_Etype (N, Standard_Wide_String); @@ -6989,14 +6967,12 @@ package body Sem_Attr is then Check_Restriction (No_Fixed_IO, P); end if; - end Wide_Image; --------------------- -- Wide_Wide_Image -- --------------------- - when Attribute_Wide_Wide_Image => Wide_Wide_Image : - begin + when Attribute_Wide_Wide_Image => Check_Scalar_Type; Set_Etype (N, Standard_Wide_Wide_String); Check_E1; @@ -7010,14 +6986,12 @@ package body Sem_Attr is then Check_Restriction (No_Fixed_IO, P); end if; - end Wide_Wide_Image; ---------------- -- Wide_Value -- ---------------- - when Attribute_Wide_Value => Wide_Value : - begin + when Attribute_Wide_Value => Check_SPARK_05_Restriction_On_Attribute; Check_E1; Check_Scalar_Type; @@ -7035,14 +7009,12 @@ package body Sem_Attr is then Check_Restriction (No_Fixed_IO, P); end if; - end Wide_Value; --------------------- -- Wide_Wide_Value -- --------------------- - when Attribute_Wide_Wide_Value => Wide_Wide_Value : - begin + when Attribute_Wide_Wide_Value => Check_E1; Check_Scalar_Type; @@ -7059,7 +7031,6 @@ package body Sem_Attr is then Check_Restriction (No_Fixed_IO, P); end if; - end Wide_Wide_Value; --------------------- -- Wide_Wide_Width -- @@ -7119,10 +7090,11 @@ package body Sem_Attr is begin case Attr_Id is - when Attribute_Callable | - Attribute_Caller | - Attribute_Count | - Attribute_Terminated => + when Attribute_Callable + | Attribute_Caller + | Attribute_Count + | Attribute_Terminated + => Unused := RTE (RE_Tasking_State); when others => @@ -8187,12 +8159,14 @@ package body Sem_Attr is -- Attributes related to Ada 2012 iterators (placeholder ???) - when Attribute_Constant_Indexing | - Attribute_Default_Iterator | - Attribute_Implicit_Dereference | - Attribute_Iterator_Element | - Attribute_Iterable | - Attribute_Variable_Indexing => null; + when Attribute_Constant_Indexing + | Attribute_Default_Iterator + | Attribute_Implicit_Dereference + | Attribute_Iterator_Element + | Attribute_Iterable + | Attribute_Variable_Indexing + => + null; -- Internal attributes used to deal with Ada 2012 delayed aspects. -- These were already rejected by the parser. Thus they shouldn't @@ -8488,8 +8462,7 @@ package body Sem_Attr is -- First -- ----------- - when Attribute_First => First_Attr : - begin + when Attribute_First => Set_Bounds; if Compile_Time_Known_Value (Lo_Bound) then @@ -8502,14 +8475,12 @@ package body Sem_Attr is else Check_Concurrent_Discriminant (Lo_Bound); end if; - end First_Attr; ----------------- -- First_Valid -- ----------------- - when Attribute_First_Valid => First_Valid : - begin + when Attribute_First_Valid => if Has_Predicates (P_Type) and then Has_Static_Predicate (P_Type) then @@ -8528,7 +8499,6 @@ package body Sem_Attr is Set_Bounds; Fold_Uint (N, Expr_Value (Lo_Bound), Static); end if; - end First_Valid; ----------------- -- Fixed_Value -- @@ -8721,8 +8691,7 @@ package body Sem_Attr is -- Last -- ---------- - when Attribute_Last => Last_Attr : - begin + when Attribute_Last => Set_Bounds; if Compile_Time_Known_Value (Hi_Bound) then @@ -8735,14 +8704,12 @@ package body Sem_Attr is else Check_Concurrent_Discriminant (Hi_Bound); end if; - end Last_Attr; ---------------- -- Last_Valid -- ---------------- - when Attribute_Last_Valid => Last_Valid : - begin + when Attribute_Last_Valid => if Has_Predicates (P_Type) and then Has_Static_Predicate (P_Type) then @@ -8761,7 +8728,6 @@ package body Sem_Attr is Set_Bounds; Fold_Uint (N, Expr_Value (Hi_Bound), Static); end if; - end Last_Valid; ------------------ -- Leading_Part -- @@ -9055,15 +9021,13 @@ package body Sem_Attr is -- Max -- --------- - when Attribute_Max => Max : - begin + when Attribute_Max => if Is_Real_Type (P_Type) then Fold_Ureal (N, UR_Max (Expr_Value_R (E1), Expr_Value_R (E2)), Static); else Fold_Uint (N, UI_Max (Expr_Value (E1), Expr_Value (E2)), Static); end if; - end Max; ---------------------------------- -- Max_Alignment_For_Allocation -- @@ -9075,18 +9039,17 @@ package body Sem_Attr is -- and the alignment of the dope. Also, if the alignment is unknown, we -- use the max (it's OK to be pessimistic). - when Attribute_Max_Alignment_For_Allocation => - declare - A : Uint := UI_From_Int (Ttypes.Maximum_Alignment); - begin - if Known_Alignment (P_Type) and then - (not Is_Array_Type (P_Type) or else Alignment (P_Type) > A) - then - A := Alignment (P_Type); - end if; + when Attribute_Max_Alignment_For_Allocation => Max_Align : declare + A : Uint := UI_From_Int (Ttypes.Maximum_Alignment); + begin + if Known_Alignment (P_Type) + and then (not Is_Array_Type (P_Type) or else Alignment (P_Type) > A) + then + A := Alignment (P_Type); + end if; Fold_Uint (N, A, Static); - end; + end Max_Align; ---------------------------------- -- Max_Size_In_Storage_Elements -- @@ -9108,37 +9071,36 @@ package body Sem_Attr is -- Mechanism_Code -- -------------------- - when Attribute_Mechanism_Code => - declare - Val : Int; - Formal : Entity_Id; - Mech : Mechanism_Type; + when Attribute_Mechanism_Code => Mechanism_Code : declare + Formal : Entity_Id; + Mech : Mechanism_Type; + Val : Int; - begin - if No (E1) then - Mech := Mechanism (P_Entity); + begin + if No (E1) then + Mech := Mechanism (P_Entity); - else - Val := UI_To_Int (Expr_Value (E1)); + else + Val := UI_To_Int (Expr_Value (E1)); - Formal := First_Formal (P_Entity); - for J in 1 .. Val - 1 loop - Next_Formal (Formal); - end loop; - Mech := Mechanism (Formal); - end if; + Formal := First_Formal (P_Entity); + for J in 1 .. Val - 1 loop + Next_Formal (Formal); + end loop; - if Mech < 0 then - Fold_Uint (N, UI_From_Int (Int (-Mech)), Static); - end if; - end; + Mech := Mechanism (Formal); + end if; + + if Mech < 0 then + Fold_Uint (N, UI_From_Int (Int (-Mech)), Static); + end if; + end Mechanism_Code; --------- -- Min -- --------- - when Attribute_Min => Min : - begin + when Attribute_Min => if Is_Real_Type (P_Type) then Fold_Ureal (N, UR_Min (Expr_Value_R (E1), Expr_Value_R (E2)), Static); @@ -9146,7 +9108,6 @@ package body Sem_Attr is Fold_Uint (N, UI_Min (Expr_Value (E1), Expr_Value (E2)), Static); end if; - end Min; --------- -- Mod -- @@ -9253,8 +9214,8 @@ package body Sem_Attr is -- Pred -- ---------- - when Attribute_Pred => Pred : - begin + when Attribute_Pred => + -- Floating-point case if Is_Floating_Point_Type (P_Type) then @@ -9293,7 +9254,6 @@ package body Sem_Attr is Fold_Uint (N, Expr_Value (E1) - 1, Static); end if; - end Pred; ----------- -- Range -- @@ -9309,7 +9269,10 @@ package body Sem_Attr is -- Range_Length -- ------------------ - when Attribute_Range_Length => + when Attribute_Range_Length => Range_Length : declare + Diff : aliased Uint; + + begin Set_Bounds; -- Can fold if both bounds are compile time known @@ -9326,29 +9289,24 @@ package body Sem_Attr is -- One more case is where Hi_Bound and Lo_Bound are compile-time -- comparable, and we can figure out the difference between them. - declare - Diff : aliased Uint; - - begin - case - Compile_Time_Compare + case Compile_Time_Compare (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False) - is - when EQ => - Fold_Uint (N, Uint_1, Static); + is + when EQ => + Fold_Uint (N, Uint_1, Static); - when GT => - Fold_Uint (N, Uint_0, Static); + when GT => + Fold_Uint (N, Uint_0, Static); - when LT => - if Diff /= No_Uint then - Fold_Uint (N, Diff + 1, Static); - end if; + when LT => + if Diff /= No_Uint then + Fold_Uint (N, Diff + 1, Static); + end if; - when others => - null; - end case; - end; + when others => + null; + end case; + end Range_Length; --------- -- Ref -- @@ -9383,18 +9341,15 @@ package body Sem_Attr is -- Restriction -- ----------------- - when Attribute_Restriction_Set => Restriction_Set : declare - begin + when Attribute_Restriction_Set => Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); Set_Is_Static_Expression (N); - end Restriction_Set; ----------- -- Round -- ----------- - when Attribute_Round => Round : - declare + when Attribute_Round => Round : declare Sr : Ureal; Si : Uint; @@ -9508,53 +9463,57 @@ package body Sem_Attr is -- one of the places where it is annoying that a size of zero means two -- things (zero size for scalars, unspecified size for non-scalars). - when Attribute_Size | Attribute_VADS_Size => Size : declare - P_TypeA : constant Entity_Id := Underlying_Type (P_Type); - - begin - if Is_Scalar_Type (P_TypeA) or else RM_Size (P_TypeA) /= Uint_0 then + when Attribute_Size + | Attribute_VADS_Size + => + Size : declare + P_TypeA : constant Entity_Id := Underlying_Type (P_Type); - -- VADS_Size case + begin + if Is_Scalar_Type (P_TypeA) + or else RM_Size (P_TypeA) /= Uint_0 + then + -- VADS_Size case - if Id = Attribute_VADS_Size or else Use_VADS_Size then - declare - S : constant Node_Id := Size_Clause (P_TypeA); + if Id = Attribute_VADS_Size or else Use_VADS_Size then + declare + S : constant Node_Id := Size_Clause (P_TypeA); - begin - -- If a size clause applies, then use the size from it. - -- This is one of the rare cases where we can use the - -- Size_Clause field for a subtype when Has_Size_Clause - -- is False. Consider: + begin + -- If a size clause applies, then use the size from it. + -- This is one of the rare cases where we can use the + -- Size_Clause field for a subtype when Has_Size_Clause + -- is False. Consider: - -- type x is range 1 .. 64; - -- for x'size use 12; - -- subtype y is x range 0 .. 3; + -- type x is range 1 .. 64; + -- for x'size use 12; + -- subtype y is x range 0 .. 3; - -- Here y has a size clause inherited from x, but normally - -- it does not apply, and y'size is 2. However, y'VADS_Size - -- is indeed 12 and not 2. + -- Here y has a size clause inherited from x, but + -- normally it does not apply, and y'size is 2. However, + -- y'VADS_Size is indeed 12 and not 2. - if Present (S) - and then Is_OK_Static_Expression (Expression (S)) - then - Fold_Uint (N, Expr_Value (Expression (S)), Static); + if Present (S) + and then Is_OK_Static_Expression (Expression (S)) + then + Fold_Uint (N, Expr_Value (Expression (S)), Static); - -- If no size is specified, then we simply use the object - -- size in the VADS_Size case (e.g. Natural'Size is equal - -- to Integer'Size, not one less). + -- If no size is specified, then we simply use the object + -- size in the VADS_Size case (e.g. Natural'Size is equal + -- to Integer'Size, not one less). - else - Fold_Uint (N, Esize (P_TypeA), Static); - end if; - end; + else + Fold_Uint (N, Esize (P_TypeA), Static); + end if; + end; - -- Normal case (Size) in which case we want the RM_Size + -- Normal case (Size) in which case we want the RM_Size - else - Fold_Uint (N, RM_Size (P_TypeA), Static); + else + Fold_Uint (N, RM_Size (P_TypeA), Static); + end if; end if; - end if; - end Size; + end Size; ----------- -- Small -- @@ -9596,8 +9555,7 @@ package body Sem_Attr is -- Succ -- ---------- - when Attribute_Succ => Succ : - begin + when Attribute_Succ => -- Floating-point case if Is_Floating_Point_Type (P_Type) then @@ -9635,7 +9593,6 @@ package body Sem_Attr is Fold_Uint (N, Expr_Value (E1) + 1, Static); end if; end if; - end Succ; ---------------- -- Truncation -- @@ -9750,8 +9707,7 @@ package body Sem_Attr is -- Val -- --------- - when Attribute_Val => Val : - begin + when Attribute_Val => if Expr_Value (E1) < Expr_Value (Type_Low_Bound (P_Base_Type)) or else Expr_Value (E1) > Expr_Value (Type_High_Bound (P_Base_Type)) @@ -9767,7 +9723,6 @@ package body Sem_Attr is else Fold_Uint (N, Expr_Value (E1), Static); end if; - end Val; ---------------- -- Value_Size -- @@ -9780,6 +9735,7 @@ package body Sem_Attr is when Attribute_Value_Size => Value_Size : declare P_TypeA : constant Entity_Id := Underlying_Type (P_Type); + begin if Is_Scalar_Type (P_TypeA) or else RM_Size (P_TypeA) /= Uint_0 then Fold_Uint (N, RM_Size (P_TypeA), Static); @@ -9833,10 +9789,10 @@ package body Sem_Attr is -- This processing also handles the case of Wide_[Wide_]Width - when Attribute_Width | - Attribute_Wide_Width | - Attribute_Wide_Wide_Width => Width : - begin + when Attribute_Width + | Attribute_Wide_Width + | Attribute_Wide_Wide_Width + => if Compile_Time_Known_Bounds (P_Type) then -- Floating-point types @@ -9944,29 +9900,83 @@ package body Sem_Attr is -- names (length = 12). case C is - when Reserved_128 | Reserved_129 | - Reserved_132 | Reserved_153 - => Wt := 12; - - when BS | HT | LF | VT | FF | CR | - SO | SI | EM | FS | GS | RS | - US | RI | MW | ST | PM - => Wt := 2; - - when NUL | SOH | STX | ETX | EOT | - ENQ | ACK | BEL | DLE | DC1 | - DC2 | DC3 | DC4 | NAK | SYN | - ETB | CAN | SUB | ESC | DEL | - BPH | NBH | NEL | SSA | ESA | - HTS | HTJ | VTS | PLD | PLU | - SS2 | SS3 | DCS | PU1 | PU2 | - STS | CCH | SPA | EPA | SOS | - SCI | CSI | OSC | APC - => Wt := 3; - - when Space .. Tilde | - No_Break_Space .. LC_Y_Diaeresis - => + when Reserved_128 + | Reserved_129 + | Reserved_132 + | Reserved_153 + => + Wt := 12; + + when BS + | CR + | EM + | FF + | FS + | GS + | HT + | LF + | MW + | PM + | RI + | RS + | SI + | SO + | ST + | US + | VT + => + Wt := 2; + + when ACK + | APC + | BEL + | BPH + | CAN + | CCH + | CSI + | DC1 + | DC2 + | DC3 + | DC4 + | DCS + | DEL + | DLE + | ENQ + | EOT + | EPA + | ESA + | ESC + | ETB + | ETX + | HTJ + | HTS + | NAK + | NBH + | NEL + | NUL + | OSC + | PLD + | PLU + | PU1 + | PU2 + | SCI + | SOH + | SOS + | SPA + | SS2 + | SS3 + | SSA + | STS + | STX + | SUB + | SYN + | VTS + => + Wt := 3; + + when Space .. Tilde + | No_Break_Space .. LC_Y_Diaeresis + => -- Special case of soft hyphen in Ada 2005 if C = Character'Val (16#AD#) @@ -10076,13 +10086,13 @@ package body Sem_Attr is end; end if; end if; - end Width; -- The following attributes denote functions that cannot be folded - when Attribute_From_Any | - Attribute_To_Any | - Attribute_TypeCode => + when Attribute_From_Any + | Attribute_To_Any + | Attribute_TypeCode + => null; -- The following attributes can never be folded, and furthermore we @@ -10091,69 +10101,69 @@ package body Sem_Attr is -- a result of the processing in Analyze_Attribute or earlier in -- this procedure. - when Attribute_Abort_Signal | - Attribute_Access | - Attribute_Address | - Attribute_Address_Size | - Attribute_Asm_Input | - Attribute_Asm_Output | - Attribute_Base | - Attribute_Bit_Order | - Attribute_Bit_Position | - Attribute_Callable | - Attribute_Caller | - Attribute_Class | - Attribute_Code_Address | - Attribute_Compiler_Version | - Attribute_Count | - Attribute_Default_Bit_Order | - Attribute_Default_Scalar_Storage_Order | - Attribute_Deref | - Attribute_Elaborated | - Attribute_Elab_Body | - Attribute_Elab_Spec | - Attribute_Elab_Subp_Body | - Attribute_Enabled | - Attribute_External_Tag | - Attribute_Fast_Math | - Attribute_First_Bit | - Attribute_Img | - Attribute_Input | - Attribute_Last_Bit | - Attribute_Library_Level | - Attribute_Maximum_Alignment | - Attribute_Old | - Attribute_Output | - Attribute_Partition_ID | - Attribute_Pool_Address | - Attribute_Position | - Attribute_Priority | - Attribute_Read | - Attribute_Result | - Attribute_Scalar_Storage_Order | - Attribute_Simple_Storage_Pool | - Attribute_Storage_Pool | - Attribute_Storage_Size | - Attribute_Storage_Unit | - Attribute_Stub_Type | - Attribute_System_Allocator_Alignment | - Attribute_Tag | - Attribute_Target_Name | - Attribute_Terminated | - Attribute_To_Address | - Attribute_Type_Key | - Attribute_Unchecked_Access | - Attribute_Universal_Literal_String | - Attribute_Unrestricted_Access | - Attribute_Valid | - Attribute_Valid_Scalars | - Attribute_Value | - Attribute_Wchar_T_Size | - Attribute_Wide_Value | - Attribute_Wide_Wide_Value | - Attribute_Word_Size | - Attribute_Write => - + when Attribute_Abort_Signal + | Attribute_Access + | Attribute_Address + | Attribute_Address_Size + | Attribute_Asm_Input + | Attribute_Asm_Output + | Attribute_Base + | Attribute_Bit_Order + | Attribute_Bit_Position + | Attribute_Callable + | Attribute_Caller + | Attribute_Class + | Attribute_Code_Address + | Attribute_Compiler_Version + | Attribute_Count + | Attribute_Default_Bit_Order + | Attribute_Default_Scalar_Storage_Order + | Attribute_Deref + | Attribute_Elaborated + | Attribute_Elab_Body + | Attribute_Elab_Spec + | Attribute_Elab_Subp_Body + | Attribute_Enabled + | Attribute_External_Tag + | Attribute_Fast_Math + | Attribute_First_Bit + | Attribute_Img + | Attribute_Input + | Attribute_Last_Bit + | Attribute_Library_Level + | Attribute_Maximum_Alignment + | Attribute_Old + | Attribute_Output + | Attribute_Partition_ID + | Attribute_Pool_Address + | Attribute_Position + | Attribute_Priority + | Attribute_Read + | Attribute_Result + | Attribute_Scalar_Storage_Order + | Attribute_Simple_Storage_Pool + | Attribute_Storage_Pool + | Attribute_Storage_Size + | Attribute_Storage_Unit + | Attribute_Stub_Type + | Attribute_System_Allocator_Alignment + | Attribute_Tag + | Attribute_Target_Name + | Attribute_Terminated + | Attribute_To_Address + | Attribute_Type_Key + | Attribute_Unchecked_Access + | Attribute_Universal_Literal_String + | Attribute_Unrestricted_Access + | Attribute_Valid + | Attribute_Valid_Scalars + | Attribute_Value + | Attribute_Wchar_T_Size + | Attribute_Wide_Value + | Attribute_Wide_Wide_Value + | Attribute_Word_Size + | Attribute_Write + => raise Program_Error; end case; @@ -10354,10 +10364,8 @@ package body Sem_Attr is when Attribute_Access | Attribute_Unchecked_Access - | Attribute_Unrestricted_Access => - - Access_Attribute : - begin + | Attribute_Unrestricted_Access + => -- Note possible modification if we have a variable if Is_Variable (P) then @@ -11181,7 +11189,6 @@ package body Sem_Attr is end if; end; end if; - end Access_Attribute; ------------- -- Address -- @@ -11190,9 +11197,9 @@ package body Sem_Attr is -- Deal with resolving the type for Address attribute, overloading -- is not permitted here, since there is no context to resolve it. - when Attribute_Address | Attribute_Code_Address => - Address_Attribute : begin - + when Attribute_Address + | Attribute_Code_Address + => -- To be safe, assume that if the address of a variable is taken, -- it may be modified via this address, so note modification. @@ -11301,7 +11308,6 @@ package body Sem_Attr is end if; end; end if; - end Address_Attribute; ------------------ -- Body_Version -- @@ -11425,81 +11431,77 @@ package body Sem_Attr is -- specifically mentions this equivalence, we take care that the -- prefix is only evaluated once). - when Attribute_Range => Range_Attribute : - declare - LB : Node_Id; - HB : Node_Id; - Dims : List_Id; + when Attribute_Range => Range_Attribute : declare + Dims : List_Id; + HB : Node_Id; + LB : Node_Id; - begin - if not Is_Entity_Name (P) - or else not Is_Type (Entity (P)) - then - Resolve (P); - end if; + begin + if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) then + Resolve (P); + end if; - Dims := Expressions (N); + Dims := Expressions (N); - HB := - Make_Attribute_Reference (Loc, - Prefix => Duplicate_Subexpr (P, Name_Req => True), - Attribute_Name => Name_Last, - Expressions => Dims); + HB := + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (P, Name_Req => True), + Attribute_Name => Name_Last, + Expressions => Dims); - LB := - Make_Attribute_Reference (Loc, - Prefix => P, - Attribute_Name => Name_First, - Expressions => (Dims)); + LB := + Make_Attribute_Reference (Loc, + Prefix => P, + Attribute_Name => Name_First, + Expressions => (Dims)); - -- Do not share the dimension indicator, if present. Even - -- though it is a static constant, its source location - -- may be modified when printing expanded code and node - -- sharing will lead to chaos in Sprint. + -- Do not share the dimension indicator, if present. Even though + -- it is a static constant, its source location may be modified + -- when printing expanded code and node sharing will lead to chaos + -- in Sprint. - if Present (Dims) then - Set_Expressions (LB, - New_List (New_Copy_Tree (First (Dims)))); - end if; + if Present (Dims) then + Set_Expressions (LB, New_List (New_Copy_Tree (First (Dims)))); + end if; - -- If the original was marked as Must_Not_Freeze (see code - -- in Sem_Ch3.Make_Index), then make sure the rewriting - -- does not freeze either. + -- If the original was marked as Must_Not_Freeze (see code in + -- Sem_Ch3.Make_Index), then make sure the rewriting does not + -- freeze either. - if Must_Not_Freeze (N) then - Set_Must_Not_Freeze (HB); - Set_Must_Not_Freeze (LB); - Set_Must_Not_Freeze (Prefix (HB)); - Set_Must_Not_Freeze (Prefix (LB)); - end if; + if Must_Not_Freeze (N) then + Set_Must_Not_Freeze (HB); + Set_Must_Not_Freeze (LB); + Set_Must_Not_Freeze (Prefix (HB)); + Set_Must_Not_Freeze (Prefix (LB)); + end if; - if Raises_Constraint_Error (Prefix (N)) then + if Raises_Constraint_Error (Prefix (N)) then - -- Preserve Sloc of prefix in the new bounds, so that - -- the posted warning can be removed if we are within - -- unreachable code. + -- Preserve Sloc of prefix in the new bounds, so that the + -- posted warning can be removed if we are within unreachable + -- code. - Set_Sloc (LB, Sloc (Prefix (N))); - Set_Sloc (HB, Sloc (Prefix (N))); - end if; + Set_Sloc (LB, Sloc (Prefix (N))); + Set_Sloc (HB, Sloc (Prefix (N))); + end if; - Rewrite (N, Make_Range (Loc, LB, HB)); - Analyze_And_Resolve (N, Typ); + Rewrite (N, Make_Range (Loc, LB, HB)); + Analyze_And_Resolve (N, Typ); - -- Ensure that the expanded range does not have side effects + -- Ensure that the expanded range does not have side effects - Force_Evaluation (LB); - Force_Evaluation (HB); + Force_Evaluation (LB); + Force_Evaluation (HB); - -- Normally after resolving attribute nodes, Eval_Attribute - -- is called to do any possible static evaluation of the node. - -- However, here since the Range attribute has just been - -- transformed into a range expression it is no longer an - -- attribute node and therefore the call needs to be avoided - -- and is accomplished by simply returning from the procedure. + -- Normally after resolving attribute nodes, Eval_Attribute + -- is called to do any possible static evaluation of the node. + -- However, here since the Range attribute has just been + -- transformed into a range expression it is no longer an + -- attribute node and therefore the call needs to be avoided + -- and is accomplished by simply returning from the procedure. - return; - end Range_Attribute; + return; + end Range_Attribute; ------------ -- Result -- @@ -11530,121 +11532,120 @@ package body Sem_Attr is -- Resolve aggregate components in component associations - when Attribute_Update => - declare - Aggr : constant Node_Id := First (Expressions (N)); - Typ : constant Entity_Id := Etype (Prefix (N)); - Assoc : Node_Id; - Comp : Node_Id; - Expr : Node_Id; + when Attribute_Update => Update : declare + Aggr : constant Node_Id := First (Expressions (N)); + Typ : constant Entity_Id := Etype (Prefix (N)); + Assoc : Node_Id; + Comp : Node_Id; + Expr : Node_Id; - begin - -- Set the Etype of the aggregate to that of the prefix, even - -- though the aggregate may not be a proper representation of a - -- value of the type (missing or duplicated associations, etc.) - -- Complete resolution of the prefix. Note that in Ada 2012 it - -- can be a qualified expression that is e.g. an aggregate. - - Set_Etype (Aggr, Typ); - Resolve (Prefix (N), Typ); - - -- For an array type, resolve expressions with the component - -- type of the array, and apply constraint checks when needed. - - if Is_Array_Type (Typ) then - Assoc := First (Component_Associations (Aggr)); - while Present (Assoc) loop - Expr := Expression (Assoc); - Resolve (Expr, Component_Type (Typ)); - - -- For scalar array components set Do_Range_Check when - -- needed. Constraint checking on non-scalar components - -- is done in Aggregate_Constraint_Checks, but only if - -- full analysis is enabled. These flags are not set in - -- the front-end in GnatProve mode. - - if Is_Scalar_Type (Component_Type (Typ)) - and then not Is_OK_Static_Expression (Expr) + begin + -- Set the Etype of the aggregate to that of the prefix, even + -- though the aggregate may not be a proper representation of a + -- value of the type (missing or duplicated associations, etc.) + -- Complete resolution of the prefix. Note that in Ada 2012 it + -- can be a qualified expression that is e.g. an aggregate. + + Set_Etype (Aggr, Typ); + Resolve (Prefix (N), Typ); + + -- For an array type, resolve expressions with the component type + -- of the array, and apply constraint checks when needed. + + if Is_Array_Type (Typ) then + Assoc := First (Component_Associations (Aggr)); + while Present (Assoc) loop + Expr := Expression (Assoc); + Resolve (Expr, Component_Type (Typ)); + + -- For scalar array components set Do_Range_Check when + -- needed. Constraint checking on non-scalar components + -- is done in Aggregate_Constraint_Checks, but only if + -- full analysis is enabled. These flags are not set in + -- the front-end in GnatProve mode. + + if Is_Scalar_Type (Component_Type (Typ)) + and then not Is_OK_Static_Expression (Expr) + then + if Is_Entity_Name (Expr) + and then Etype (Expr) = Component_Type (Typ) then - if Is_Entity_Name (Expr) - and then Etype (Expr) = Component_Type (Typ) - then - null; + null; - else - Set_Do_Range_Check (Expr); - end if; + else + Set_Do_Range_Check (Expr); end if; + end if; - -- The choices in the association are static constants, - -- or static aggregates each of whose components belongs - -- to the proper index type. However, they must also - -- belong to the index subtype (s) of the prefix, which - -- may be a subtype (e.g. given by a slice). + -- The choices in the association are static constants, + -- or static aggregates each of whose components belongs + -- to the proper index type. However, they must also + -- belong to the index subtype (s) of the prefix, which + -- may be a subtype (e.g. given by a slice). - -- Choices may also be identifiers with no staticness - -- requirements, in which case they must resolve to the - -- index type. + -- Choices may also be identifiers with no staticness + -- requirements, in which case they must resolve to the + -- index type. - declare - C : Node_Id; - C_E : Node_Id; - Indx : Node_Id; + declare + C : Node_Id; + C_E : Node_Id; + Indx : Node_Id; - begin - C := First (Choices (Assoc)); - while Present (C) loop - Indx := First_Index (Etype (Prefix (N))); + begin + C := First (Choices (Assoc)); + while Present (C) loop + Indx := First_Index (Etype (Prefix (N))); - if Nkind (C) /= N_Aggregate then - Analyze_And_Resolve (C, Etype (Indx)); - Apply_Constraint_Check (C, Etype (Indx)); - Check_Non_Static_Context (C); + if Nkind (C) /= N_Aggregate then + Analyze_And_Resolve (C, Etype (Indx)); + Apply_Constraint_Check (C, Etype (Indx)); + Check_Non_Static_Context (C); - else - C_E := First (Expressions (C)); - while Present (C_E) loop - Analyze_And_Resolve (C_E, Etype (Indx)); - Apply_Constraint_Check (C_E, Etype (Indx)); - Check_Non_Static_Context (C_E); - - Next (C_E); - Next_Index (Indx); - end loop; - end if; + else + C_E := First (Expressions (C)); + while Present (C_E) loop + Analyze_And_Resolve (C_E, Etype (Indx)); + Apply_Constraint_Check (C_E, Etype (Indx)); + Check_Non_Static_Context (C_E); + + Next (C_E); + Next_Index (Indx); + end loop; + end if; - Next (C); - end loop; - end; + Next (C); + end loop; + end; - Next (Assoc); - end loop; + Next (Assoc); + end loop; - -- For a record type, use type of each component, which is - -- recorded during analysis. + -- For a record type, use type of each component, which is + -- recorded during analysis. - else - Assoc := First (Component_Associations (Aggr)); - while Present (Assoc) loop - Comp := First (Choices (Assoc)); - Expr := Expression (Assoc); + else + Assoc := First (Component_Associations (Aggr)); + while Present (Assoc) loop + Comp := First (Choices (Assoc)); + Expr := Expression (Assoc); - if Nkind (Comp) /= N_Others_Choice - and then not Error_Posted (Comp) - then - Resolve (Expr, Etype (Entity (Comp))); + if Nkind (Comp) /= N_Others_Choice + and then not Error_Posted (Comp) + then + Resolve (Expr, Etype (Entity (Comp))); - if Is_Scalar_Type (Etype (Entity (Comp))) - and then not Is_OK_Static_Expression (Expr) - then - Set_Do_Range_Check (Expr); - end if; + if Is_Scalar_Type (Etype (Entity (Comp))) + and then not Is_OK_Static_Expression (Expr) + then + Set_Do_Range_Check (Expr); end if; + end if; - Next (Assoc); - end loop; - end if; - end; + Next (Assoc); + end loop; + end if; + end Update; --------- -- Val -- diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 5232696433b..0ba45981558 100644 --- a/gcc/ada/sem_aux.adb +++ b/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 => diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index 28742e45683..7bc75b1e6d8 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.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- -- @@ -486,7 +486,6 @@ package body Sem_Cat is when others => null; - end case; end if; @@ -746,13 +745,17 @@ package body Sem_Cat is if Nkind (PN) = N_Pragma then case Get_Pragma_Id (PN) is - when Pragma_All_Calls_Remote | - Pragma_Preelaborate | - Pragma_Pure | - Pragma_Remote_Call_Interface | - Pragma_Remote_Types | - Pragma_Shared_Passive => Analyze (PN); - when others => null; + when Pragma_All_Calls_Remote + | Pragma_Preelaborate + | Pragma_Pure + | Pragma_Remote_Call_Interface + | Pragma_Remote_Types + | Pragma_Shared_Passive + => + Analyze (PN); + + when others => + null; end case; end if; @@ -2089,30 +2092,37 @@ package body Sem_Cat is begin case K is - when N_Op | N_Membership_Test => - return True; - when N_Aggregate | N_Component_Association - | N_Index_Or_Discriminant_Constraint => + | N_Index_Or_Discriminant_Constraint + | N_Membership_Test + | N_Op + => return True; when N_Attribute_Reference => - return Attribute_Name (Parent (N)) /= Name_Address - and then Attribute_Name (Parent (N)) /= Name_Access - and then Attribute_Name (Parent (N)) /= Name_Unchecked_Access - and then - Attribute_Name (Parent (N)) /= Name_Unrestricted_Access; + declare + Attr : constant Name_Id := Attribute_Name (Parent (N)); + + begin + return Attr /= Name_Address + and then Attr /= Name_Access + and then Attr /= Name_Unchecked_Access + and then Attr /= Name_Unrestricted_Access; + end; when N_Indexed_Component => - return (N /= Prefix (Parent (N)) - or else Is_Primary (Parent (N))); + return N /= Prefix (Parent (N)) or else Is_Primary (Parent (N)); - when N_Qualified_Expression | N_Type_Conversion => + when N_Qualified_Expression + | N_Type_Conversion + => return Is_Primary (Parent (N)); - when N_Assignment_Statement | N_Object_Declaration => - return (N = Expression (Parent (N))); + when N_Assignment_Statement + | N_Object_Declaration + => + return N = Expression (Parent (N)); when N_Selected_Component => return Is_Primary (Parent (N)); diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 264a2846a7e..c1f671fb43a 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -3664,10 +3664,11 @@ package body Sem_Ch10 is -- Protect the frontend against previous critical errors case Nkind (Unit (Library_Unit (W))) is - when N_Subprogram_Declaration | - N_Package_Declaration | - N_Generic_Subprogram_Declaration | - N_Generic_Package_Declaration => + when N_Generic_Package_Declaration + | N_Generic_Subprogram_Declaration + | N_Package_Declaration + | N_Subprogram_Declaration + => null; when others => @@ -6003,8 +6004,9 @@ package body Sem_Ch10 is Error_Msg_N ("subprograms not allowed in limited with_clauses", N); return; - when N_Generic_Package_Declaration | - N_Generic_Subprogram_Declaration => + when N_Generic_Package_Declaration + | N_Generic_Subprogram_Declaration + => Error_Msg_N ("generics not allowed in limited with_clauses", N); return; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 2a5e66002ea..89c008092f8 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -1459,7 +1459,6 @@ package body Sem_Ch12 is Kind := Nkind (Analyzed_Formal); case Nkind (Formal) is - when N_Formal_Subprogram_Declaration => exit when Kind in N_Formal_Subprogram_Declaration and then @@ -1473,7 +1472,10 @@ package body Sem_Ch12 is N_Generic_Package_Declaration, N_Package_Declaration); - when N_Use_Package_Clause | N_Use_Type_Clause => exit; + when N_Use_Package_Clause + | N_Use_Type_Clause + => + exit; when others => @@ -1855,8 +1857,9 @@ package body Sem_Ch12 is -- they belong (we mustn't recopy them since this would mess up -- the Sloc values). - when N_Use_Package_Clause | - N_Use_Type_Clause => + when N_Use_Package_Clause + | N_Use_Type_Clause + => if Nkind (Original_Node (I_Node)) = N_Formal_Package_Declaration then @@ -1868,7 +1871,6 @@ package body Sem_Ch12 is when others => raise Program_Error; - end case; Formal := Saved_Formal; @@ -2656,13 +2658,13 @@ package body Sem_Ch12 is -- continue analysis to minimize cascaded errors. Error_Msg_N - ("generic parent cannot be used as formal package " - & "of a child unit", Gen_Id); + ("generic parent cannot be used as formal package of a child " + & "unit", Gen_Id); else Error_Msg_N - ("generic package cannot be used as a formal package " - & "within itself", Gen_Id); + ("generic package cannot be used as a formal package within " + & "itself", Gen_Id); Restore_Env; goto Leave; end if; @@ -3135,56 +3137,56 @@ package body Sem_Ch12 is -- Enter the new name, and branch to specific routine case Nkind (Def) is - when N_Formal_Private_Type_Definition => + when N_Formal_Private_Type_Definition => Analyze_Formal_Private_Type (N, T, Def); - when N_Formal_Derived_Type_Definition => + when N_Formal_Derived_Type_Definition => Analyze_Formal_Derived_Type (N, T, Def); - when N_Formal_Incomplete_Type_Definition => + when N_Formal_Incomplete_Type_Definition => Analyze_Formal_Incomplete_Type (T, Def); - when N_Formal_Discrete_Type_Definition => + when N_Formal_Discrete_Type_Definition => Analyze_Formal_Discrete_Type (T, Def); - when N_Formal_Signed_Integer_Type_Definition => + when N_Formal_Signed_Integer_Type_Definition => Analyze_Formal_Signed_Integer_Type (T, Def); - when N_Formal_Modular_Type_Definition => + when N_Formal_Modular_Type_Definition => Analyze_Formal_Modular_Type (T, Def); - when N_Formal_Floating_Point_Definition => + when N_Formal_Floating_Point_Definition => Analyze_Formal_Floating_Type (T, Def); when N_Formal_Ordinary_Fixed_Point_Definition => Analyze_Formal_Ordinary_Fixed_Point_Type (T, Def); - when N_Formal_Decimal_Fixed_Point_Definition => + when N_Formal_Decimal_Fixed_Point_Definition => Analyze_Formal_Decimal_Fixed_Point_Type (T, Def); when N_Array_Type_Definition => Analyze_Formal_Array_Type (T, Def); - when N_Access_To_Object_Definition | - N_Access_Function_Definition | - N_Access_Procedure_Definition => + when N_Access_Function_Definition + | N_Access_Procedure_Definition + | N_Access_To_Object_Definition + => Analyze_Generic_Access_Type (T, Def); -- Ada 2005: a interface declaration is encoded as an abstract -- record declaration or a abstract type derivation. - when N_Record_Definition => + when N_Record_Definition => Analyze_Formal_Interface_Type (N, T, Def); - when N_Derived_Type_Definition => + when N_Derived_Type_Definition => Analyze_Formal_Derived_Interface_Type (N, T, Def); - when N_Error => + when N_Error => null; - when others => + when others => raise Program_Error; - end case; Set_Is_Generic_Type (T); @@ -9661,18 +9663,20 @@ package body Sem_Ch12 is begin case Nkind (Original_Node (F)) is - when N_Formal_Object_Declaration | - N_Formal_Type_Declaration => + when N_Formal_Object_Declaration + | N_Formal_Type_Declaration + => Formal_Ent := Defining_Identifier (F); while Chars (Act) /= Chars (Formal_Ent) loop Next_Entity (Act); end loop; - when N_Formal_Subprogram_Declaration | - N_Formal_Package_Declaration | - N_Package_Declaration | - N_Generic_Package_Declaration => + when N_Formal_Package_Declaration + | N_Formal_Subprogram_Declaration + | N_Generic_Package_Declaration + | N_Package_Declaration + => Formal_Ent := Defining_Entity (F); while Chars (Act) /= Chars (Formal_Ent) loop @@ -9766,19 +9770,19 @@ package body Sem_Ch12 is Kind : constant Node_Kind := Nkind (Original_Node (N)); begin case Kind is - when N_Formal_Object_Declaration => + when N_Formal_Object_Declaration => return Defining_Identifier (N); - when N_Formal_Type_Declaration => + when N_Formal_Type_Declaration => return Defining_Identifier (N); when N_Formal_Subprogram_Declaration => return Defining_Unit_Name (Specification (N)); - when N_Formal_Package_Declaration => + when N_Formal_Package_Declaration => return Defining_Identifier (Original_Node (N)); - when N_Generic_Package_Declaration => + when N_Generic_Package_Declaration => return Defining_Identifier (Original_Node (N)); -- All other declarations are introduced by semantic analysis and @@ -12815,19 +12819,19 @@ package body Sem_Ch12 is when N_Access_To_Object_Definition => Validate_Access_Type_Instance; - when N_Access_Function_Definition | - N_Access_Procedure_Definition => + when N_Access_Function_Definition + | N_Access_Procedure_Definition + => Validate_Access_Subprogram_Instance; - when N_Record_Definition => + when N_Record_Definition => Validate_Interface_Type_Instance; - when N_Derived_Type_Definition => + when N_Derived_Type_Definition => Validate_Derived_Interface_Type_Instance; when others => raise Program_Error; - end case; end if; @@ -14523,14 +14527,16 @@ package body Sem_Ch12 is when N_Unary_Op => Save_Global_Descendant (Union_Id (Right_Opnd (N))); - when N_Expanded_Name | - N_Selected_Component => + when N_Expanded_Name + | N_Selected_Component + => Save_Global_Descendant (Union_Id (Prefix (N))); Save_Global_Descendant (Union_Id (Selector_Name (N))); - when N_Identifier | - N_Character_Literal | - N_Operator_Symbol => + when N_Character_Literal + | N_Identifier + | N_Operator_Symbol + => null; when others => @@ -15479,27 +15485,43 @@ package body Sem_Ch12 is end loop; case Attr_Id is - when Attribute_Adjacent | Attribute_Ceiling | Attribute_Copy_Sign | - Attribute_Floor | Attribute_Fraction | Attribute_Machine | - Attribute_Model | Attribute_Remainder | Attribute_Rounding | - Attribute_Unbiased_Rounding => + when Attribute_Adjacent + | Attribute_Ceiling + | Attribute_Copy_Sign + | Attribute_Floor + | Attribute_Fraction + | Attribute_Machine + | Attribute_Model + | Attribute_Remainder + | Attribute_Rounding + | Attribute_Unbiased_Rounding + => OK := Is_Fun and then Num_F = 1 and then Is_Floating_Point_Type (T); - when Attribute_Image | Attribute_Pred | Attribute_Succ | - Attribute_Value | Attribute_Wide_Image | - Attribute_Wide_Value => - OK := (Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T)); + when Attribute_Image + | Attribute_Pred + | Attribute_Succ + | Attribute_Value + | Attribute_Wide_Image + | Attribute_Wide_Value + => + OK := Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T); - when Attribute_Max | Attribute_Min => - OK := (Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T)); + when Attribute_Max + | Attribute_Min + => + OK := Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T); when Attribute_Input => OK := (Is_Fun and then Num_F = 1); - when Attribute_Output | Attribute_Read | Attribute_Write => - OK := (not Is_Fun and then Num_F = 2); + when Attribute_Output + | Attribute_Read + | Attribute_Write + => + OK := not Is_Fun and then Num_F = 2; when others => OK := False; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index b4319f11fe1..ec0080bbc43 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -963,7 +963,9 @@ package body Sem_Ch13 is -- Object_Size (also Size which also sets Object_Size) - when Aspect_Object_Size | Aspect_Size => + when Aspect_Object_Size + | Aspect_Size + => if not Has_Size_Clause (E) and then No (Get_Attribute_Definition_Clause @@ -1057,7 +1059,6 @@ package body Sem_Ch13 is when others => pragma Assert (Aspect_Delay (A_Id) /= Rep_Aspect); null; - end case; end if; end if; @@ -1100,7 +1101,9 @@ package body Sem_Ch13 is Par := Nearest_Ancestor (E); case A_Id is - when Aspect_Atomic | Aspect_Shared => + when Aspect_Atomic + | Aspect_Shared + => if not Is_Atomic (Par) then return; end if; @@ -1212,9 +1215,9 @@ package body Sem_Ch13 is -- For aspects whose expression is an optional Boolean, make -- the corresponding pragma at the freeze point. - when Boolean_Aspects | - Library_Unit_Aspects => - + when Boolean_Aspects + | Library_Unit_Aspects + => -- Aspects Export and Import require special handling. -- Both are by definition Boolean and may benefit from -- forward references, however their expressions are @@ -1237,9 +1240,9 @@ package body Sem_Ch13 is -- Special handling for aspects that don't correspond to -- pragmas/attributes. - when Aspect_Default_Value | - Aspect_Default_Component_Value => - + when Aspect_Default_Value + | Aspect_Default_Component_Value + => -- Do not inherit aspect for anonymous base type of a -- scalar or array type, because they apply to the first -- subtype of the type, and will be processed when that @@ -1257,10 +1260,11 @@ package body Sem_Ch13 is -- Ditto for iterator aspects, because the corresponding -- attributes may not have been analyzed yet. - when Aspect_Constant_Indexing | - Aspect_Variable_Indexing | - Aspect_Default_Iterator | - Aspect_Iterator_Element => + when Aspect_Constant_Indexing + | Aspect_Default_Iterator + | Aspect_Iterator_Element + | Aspect_Variable_Indexing + => Analyze (Expression (ASN)); if Etype (Expression (ASN)) = Any_Type then @@ -2064,32 +2068,32 @@ package body Sem_Ch13 is -- Case 1: Aspects corresponding to attribute definition -- clauses. - when Aspect_Address | - Aspect_Alignment | - Aspect_Bit_Order | - Aspect_Component_Size | - Aspect_Constant_Indexing | - Aspect_Default_Iterator | - Aspect_Dispatching_Domain | - Aspect_External_Tag | - Aspect_Input | - Aspect_Iterable | - Aspect_Iterator_Element | - Aspect_Machine_Radix | - Aspect_Object_Size | - Aspect_Output | - Aspect_Read | - Aspect_Scalar_Storage_Order | - Aspect_Secondary_Stack_Size | - Aspect_Simple_Storage_Pool | - Aspect_Size | - Aspect_Small | - Aspect_Storage_Pool | - Aspect_Stream_Size | - Aspect_Value_Size | - Aspect_Variable_Indexing | - Aspect_Write => - + when Aspect_Address + | Aspect_Alignment + | Aspect_Bit_Order + | Aspect_Component_Size + | Aspect_Constant_Indexing + | Aspect_Default_Iterator + | Aspect_Dispatching_Domain + | Aspect_External_Tag + | Aspect_Input + | Aspect_Iterable + | Aspect_Iterator_Element + | Aspect_Machine_Radix + | Aspect_Object_Size + | Aspect_Output + | Aspect_Read + | Aspect_Scalar_Storage_Order + | Aspect_Secondary_Stack_Size + | Aspect_Simple_Storage_Pool + | Aspect_Size + | Aspect_Small + | Aspect_Storage_Pool + | Aspect_Stream_Size + | Aspect_Value_Size + | Aspect_Variable_Indexing + | Aspect_Write + => -- Indexing aspects apply only to tagged type if (A_Id = Aspect_Constant_Indexing @@ -2170,10 +2174,10 @@ package body Sem_Ch13 is -- Linker_Section/Suppress/Unsuppress - when Aspect_Linker_Section | - Aspect_Suppress | - Aspect_Unsuppress => - + when Aspect_Linker_Section + | Aspect_Suppress + | Aspect_Unsuppress + => Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, @@ -2214,10 +2218,10 @@ package body Sem_Ch13 is -- Dynamic_Predicate, Predicate, Static_Predicate - when Aspect_Dynamic_Predicate | - Aspect_Predicate | - Aspect_Static_Predicate => - + when Aspect_Dynamic_Predicate + | Aspect_Predicate + | Aspect_Static_Predicate + => -- These aspects apply only to subtypes if not Is_Type (E) then @@ -2326,8 +2330,9 @@ package body Sem_Ch13 is -- External_Name, Link_Name - when Aspect_External_Name | - Aspect_Link_Name => + when Aspect_External_Name + | Aspect_Link_Name + => Analyze_Aspect_External_Link_Name; goto Continue; @@ -2346,10 +2351,10 @@ package body Sem_Ch13 is -- to duplicate than to translate the aspect in the spec into -- a pragma in the declarative part of the body. - when Aspect_CPU | - Aspect_Interrupt_Priority | - Aspect_Priority => - + when Aspect_CPU + | Aspect_Interrupt_Priority + | Aspect_Priority + => if Nkind_In (N, N_Subprogram_Body, N_Subprogram_Declaration) then @@ -2484,9 +2489,9 @@ package body Sem_Ch13 is -- Invariant, Type_Invariant - when Aspect_Invariant | - Aspect_Type_Invariant => - + when Aspect_Invariant + | Aspect_Type_Invariant + => -- Analysis of the pragma will verify placement legality: -- an invariant must apply to a private type, or appear in -- the private part of a spec and apply to a completion. @@ -3376,9 +3381,9 @@ package body Sem_Ch13 is -- generated yet because the evaluation of the boolean needs -- to be delayed till the freeze point. - when Boolean_Aspects | - Library_Unit_Aspects => - + when Boolean_Aspects + | Library_Unit_Aspects + => Set_Is_Boolean_Aspect (Aspect); -- Lock_Free aspect only apply to protected objects @@ -4624,15 +4629,16 @@ package body Sem_Ch13 is -- affect legality (except possibly to be rejected because they -- are incompatible with the compilation target). - when Attribute_Alignment | - Attribute_Bit_Order | - Attribute_Component_Size | - Attribute_Machine_Radix | - Attribute_Object_Size | - Attribute_Size | - Attribute_Small | - Attribute_Stream_Size | - Attribute_Value_Size => + when Attribute_Alignment + | Attribute_Bit_Order + | Attribute_Component_Size + | Attribute_Machine_Radix + | Attribute_Object_Size + | Attribute_Size + | Attribute_Small + | Attribute_Stream_Size + | Attribute_Value_Size + => Kill_Rep_Clause (N); return; @@ -4642,14 +4648,15 @@ package body Sem_Ch13 is -- legality, e.g. failing to provide a stream attribute for a type -- may make a program illegal. - when Attribute_External_Tag | - Attribute_Input | - Attribute_Output | - Attribute_Read | - Attribute_Simple_Storage_Pool | - Attribute_Storage_Pool | - Attribute_Storage_Size | - Attribute_Write => + when Attribute_External_Tag + | Attribute_Input + | Attribute_Output + | Attribute_Read + | Attribute_Simple_Storage_Pool + | Attribute_Storage_Pool + | Attribute_Storage_Size + | Attribute_Write + => null; -- We do not do anything here with address clauses, they will be @@ -5142,8 +5149,7 @@ package body Sem_Ch13 is -- Bit_Order attribute definition clause - when Attribute_Bit_Order => Bit_Order : declare - begin + when Attribute_Bit_Order => if not Is_Record_Type (U_Ent) then Error_Msg_N ("Bit_Order can only be defined for record type", Nam); @@ -5167,7 +5173,6 @@ package body Sem_Ch13 is end if; end if; end if; - end Bit_Order; -------------------- -- Component_Size -- @@ -5261,8 +5266,8 @@ package body Sem_Ch13 is -- CPU -- --------- - when Attribute_CPU => CPU : - begin + when Attribute_CPU => + -- CPU attribute definition clause not allowed except from aspect -- specification. @@ -5293,7 +5298,6 @@ package body Sem_Ch13 is Error_Msg_N ("attribute& cannot be set with definition clause", N); end if; - end CPU; ---------------------- -- Default_Iterator -- @@ -5355,8 +5359,8 @@ package body Sem_Ch13 is -- Dispatching_Domain -- ------------------------ - when Attribute_Dispatching_Domain => Dispatching_Domain : - begin + when Attribute_Dispatching_Domain => + -- Dispatching_Domain attribute definition clause not allowed -- except from aspect specification. @@ -5387,14 +5391,12 @@ package body Sem_Ch13 is Error_Msg_N ("attribute& cannot be set with definition clause", N); end if; - end Dispatching_Domain; ------------------ -- External_Tag -- ------------------ - when Attribute_External_Tag => External_Tag : - begin + when Attribute_External_Tag => if not Is_Tagged_Type (U_Ent) then Error_Msg_N ("should be a tagged type", Nam); end if; @@ -5420,7 +5422,6 @@ package body Sem_Ch13 is ("\??corresponding internal tag cannot be obtained", N); end if; end if; - end External_Tag; -------------------------- -- Implicit_Dereference -- @@ -5445,8 +5446,8 @@ package body Sem_Ch13 is -- Interrupt_Priority -- ------------------------ - when Attribute_Interrupt_Priority => Interrupt_Priority : - begin + when Attribute_Interrupt_Priority => + -- Interrupt_Priority attribute definition clause not allowed -- except from aspect specification. @@ -5484,7 +5485,6 @@ package body Sem_Ch13 is Error_Msg_N ("attribute& cannot be set with definition clause", N); end if; - end Interrupt_Priority; -------------- -- Iterable -- @@ -5620,8 +5620,8 @@ package body Sem_Ch13 is -- Priority -- -------------- - when Attribute_Priority => Priority : - begin + when Attribute_Priority => + -- Priority attribute definition clause not allowed except from -- aspect specification. @@ -5656,7 +5656,6 @@ package body Sem_Ch13 is Error_Msg_N ("attribute& cannot be set with definition clause", N); end if; - end Priority; ---------- -- Read -- @@ -5672,8 +5671,7 @@ package body Sem_Ch13 is -- Scalar_Storage_Order attribute definition clause - when Attribute_Scalar_Storage_Order => Scalar_Storage_Order : declare - begin + when Attribute_Scalar_Storage_Order => if not (Is_Record_Type (U_Ent) or else Is_Array_Type (U_Ent)) then Error_Msg_N ("Scalar_Storage_Order can only be defined for record or " @@ -5712,14 +5710,13 @@ package body Sem_Ch13 is Set_SSO_Set_Low_By_Default (Base_Type (U_Ent), False); Set_SSO_Set_High_By_Default (Base_Type (U_Ent), False); end if; - end Scalar_Storage_Order; -------------------------- -- Secondary_Stack_Size -- -------------------------- - when Attribute_Secondary_Stack_Size => Secondary_Stack_Size : - begin + when Attribute_Secondary_Stack_Size => + -- Secondary_Stack_Size attribute definition clause not allowed -- except from aspect specification. @@ -5753,7 +5750,6 @@ package body Sem_Ch13 is Error_Msg_N ("attribute& cannot be set with definition clause", N); end if; - end Secondary_Stack_Size; ---------- -- Size -- @@ -5922,7 +5918,10 @@ package body Sem_Ch13 is -- Storage_Pool attribute definition clause - when Attribute_Storage_Pool | Attribute_Simple_Storage_Pool => declare + when Attribute_Simple_Storage_Pool + | Attribute_Storage_Pool + => + Storage_Pool : declare Pool : Entity_Id; T : Entity_Id; @@ -5933,8 +5932,7 @@ package body Sem_Ch13 is Nam); return; - elsif not - Ekind_In (U_Ent, E_Access_Type, E_General_Access_Type) + elsif not Ekind_In (U_Ent, E_Access_Type, E_General_Access_Type) then Error_Msg_N ("storage pool can only be given for access types", Nam); @@ -6079,7 +6077,7 @@ package body Sem_Ch13 is Error_Msg_N ("incorrect reference to a Storage Pool", Expr); return; end if; - end; + end Storage_Pool; ------------------ -- Storage_Size -- @@ -7601,14 +7599,18 @@ package body Sem_Ch13 is -- And - when N_Op_And | N_And_Then => + when N_And_Then + | N_Op_And + => return Get_RList (Left_Opnd (Exp)) and Get_RList (Right_Opnd (Exp)); -- Or - when N_Op_Or | N_Or_Else => + when N_Op_Or + | N_Or_Else + => return Get_RList (Left_Opnd (Exp)) or Get_RList (Right_Opnd (Exp)); @@ -9148,9 +9150,9 @@ package body Sem_Ch13 is -- Aspects taking an optional boolean argument - when Boolean_Aspects | - Library_Unit_Aspects => - + when Boolean_Aspects + | Library_Unit_Aspects + => T := Standard_Boolean; -- Aspects corresponding to attribute definition clauses @@ -9161,7 +9163,9 @@ package body Sem_Ch13 is when Aspect_Attach_Handler => T := RTE (RE_Interrupt_ID); - when Aspect_Bit_Order | Aspect_Scalar_Storage_Order => + when Aspect_Bit_Order + | Aspect_Scalar_Storage_Order + => T := RTE (RE_Bit_Order); when Aspect_Convention => @@ -9195,7 +9199,9 @@ package body Sem_Ch13 is when Aspect_Link_Name => T := Standard_String; - when Aspect_Priority | Aspect_Interrupt_Priority => + when Aspect_Interrupt_Priority + | Aspect_Priority + => T := Standard_Integer; when Aspect_Relative_Deadline => @@ -9217,14 +9223,15 @@ package body Sem_Ch13 is when Aspect_Storage_Pool => T := Class_Wide_Type (RTE (RE_Root_Storage_Pool)); - when Aspect_Alignment | - Aspect_Component_Size | - Aspect_Machine_Radix | - Aspect_Object_Size | - Aspect_Size | - Aspect_Storage_Size | - Aspect_Stream_Size | - Aspect_Value_Size => + when Aspect_Alignment + | Aspect_Component_Size + | Aspect_Machine_Radix + | Aspect_Object_Size + | Aspect_Size + | Aspect_Storage_Size + | Aspect_Stream_Size + | Aspect_Value_Size + => T := Any_Integer; when Aspect_Linker_Section => @@ -9236,23 +9243,25 @@ package body Sem_Ch13 is -- Special case, the expression of these aspects is just an entity -- that does not need any resolution, so just analyze. - when Aspect_Input | - Aspect_Output | - Aspect_Read | - Aspect_Suppress | - Aspect_Unsuppress | - Aspect_Warnings | - Aspect_Write => + when Aspect_Input + | Aspect_Output + | Aspect_Read + | Aspect_Suppress + | Aspect_Unsuppress + | Aspect_Warnings + | Aspect_Write + => Analyze (Expression (ASN)); return; -- Same for Iterator aspects, where the expression is a function -- name. Legality rules are checked separately. - when Aspect_Constant_Indexing | - Aspect_Default_Iterator | - Aspect_Iterator_Element | - Aspect_Variable_Indexing => + when Aspect_Constant_Indexing + | Aspect_Default_Iterator + | Aspect_Iterator_Element + | Aspect_Variable_Indexing + => Analyze (Expression (ASN)); return; @@ -9289,11 +9298,12 @@ package body Sem_Ch13 is -- Invariant/Predicate take boolean expressions - when Aspect_Dynamic_Predicate | - Aspect_Invariant | - Aspect_Predicate | - Aspect_Static_Predicate | - Aspect_Type_Invariant => + when Aspect_Dynamic_Predicate + | Aspect_Invariant + | Aspect_Predicate + | Aspect_Static_Predicate + | Aspect_Type_Invariant + => T := Standard_Boolean; when Aspect_Predicate_Failure => @@ -9301,39 +9311,40 @@ package body Sem_Ch13 is -- Here is the list of aspects that don't require delay analysis - when Aspect_Abstract_State | - Aspect_Annotate | - Aspect_Async_Readers | - Aspect_Async_Writers | - Aspect_Constant_After_Elaboration | - Aspect_Contract_Cases | - Aspect_Default_Initial_Condition | - Aspect_Depends | - Aspect_Dimension | - Aspect_Dimension_System | - Aspect_Effective_Reads | - Aspect_Effective_Writes | - Aspect_Extensions_Visible | - Aspect_Ghost | - Aspect_Global | - Aspect_Implicit_Dereference | - Aspect_Initial_Condition | - Aspect_Initializes | - Aspect_Max_Queue_Length | - Aspect_Obsolescent | - Aspect_Part_Of | - Aspect_Post | - Aspect_Postcondition | - Aspect_Pre | - Aspect_Precondition | - Aspect_Refined_Depends | - Aspect_Refined_Global | - Aspect_Refined_Post | - Aspect_Refined_State | - Aspect_SPARK_Mode | - Aspect_Test_Case | - Aspect_Unimplemented | - Aspect_Volatile_Function => + when Aspect_Abstract_State + | Aspect_Annotate + | Aspect_Async_Readers + | Aspect_Async_Writers + | Aspect_Constant_After_Elaboration + | Aspect_Contract_Cases + | Aspect_Default_Initial_Condition + | Aspect_Depends + | Aspect_Dimension + | Aspect_Dimension_System + | Aspect_Effective_Reads + | Aspect_Effective_Writes + | Aspect_Extensions_Visible + | Aspect_Ghost + | Aspect_Global + | Aspect_Implicit_Dereference + | Aspect_Initial_Condition + | Aspect_Initializes + | Aspect_Max_Queue_Length + | Aspect_Obsolescent + | Aspect_Part_Of + | Aspect_Post + | Aspect_Postcondition + | Aspect_Pre + | Aspect_Precondition + | Aspect_Refined_Depends + | Aspect_Refined_Global + | Aspect_Refined_Post + | Aspect_Refined_State + | Aspect_SPARK_Mode + | Aspect_Test_Case + | Aspect_Unimplemented + | Aspect_Volatile_Function + => raise Program_Error; end case; @@ -9375,11 +9386,10 @@ package body Sem_Ch13 is if Present (Address_Clause (Entity ((Nod)))) then Error_Msg_NE ("invalid address clause for initialized object &!", - Nod, U_Ent); - Error_Msg_NE - ("address for& cannot" & - " depend on another address clause! (RM 13.1(22))!", Nod, U_Ent); + Error_Msg_NE + ("address for& cannot depend on another address clause! " + & "(RM 13.1(22))!", Nod, U_Ent); elsif In_Same_Source_Unit (Entity (Nod), U_Ent) and then Sloc (U_Ent) < Sloc (Entity (Nod)) @@ -9409,9 +9419,8 @@ package body Sem_Ch13 is ("invalid address clause for initialized object &!", Nod, U_Ent); Error_Msg_N - ("\address cannot depend on component" & - " of discriminated record (RM 13.1(22))!", - Nod); + ("\address cannot depend on component of discriminated " + & "record (RM 13.1(22))!", Nod); else Check_At_Constant_Address (Prefix (Nod)); end if; @@ -9442,10 +9451,14 @@ package body Sem_Ch13 is end if; case Nkind (Nod) is - when N_Empty | N_Error => + when N_Empty + | N_Error + => return; - when N_Identifier | N_Expanded_Name => + when N_Expanded_Name + | N_Identifier + => Ent := Entity (Nod); -- We need to look at the original node if it is different @@ -9551,9 +9564,10 @@ package body Sem_Ch13 is Set_Etype (Nod, Base_Type (Etype (Nod))); end if; - when N_Real_Literal | - N_String_Literal | - N_Character_Literal => + when N_Character_Literal + | N_Real_Literal + | N_String_Literal + => return; when N_Range => @@ -9602,17 +9616,21 @@ package body Sem_Ch13 is when N_Null => return; - when N_Binary_Op | N_Short_Circuit | N_Membership_Test => + when N_Binary_Op + | N_Membership_Test + | N_Short_Circuit + => Check_Expr_Constants (Left_Opnd (Nod)); Check_Expr_Constants (Right_Opnd (Nod)); when N_Unary_Op => Check_Expr_Constants (Right_Opnd (Nod)); - when N_Type_Conversion | - N_Qualified_Expression | - N_Allocator | - N_Unchecked_Type_Conversion => + when N_Allocator + | N_Qualified_Expression + | N_Type_Conversion + | N_Unchecked_Type_Conversion + => Check_Expr_Constants (Expression (Nod)); when N_Function_Call => @@ -12706,14 +12724,15 @@ package body Sem_Ch13 is -- subprograms, or that may mention current instances of -- types. These will require special handling (???TBD). - when Aspect_Predicate | - Aspect_Predicate_Failure | - Aspect_Invariant => + when Aspect_Invariant + | Aspect_Predicate + | Aspect_Predicate_Failure + => null; - when Aspect_Dynamic_Predicate | - Aspect_Static_Predicate => - + when Aspect_Dynamic_Predicate + | Aspect_Static_Predicate + => -- Build predicate function specification and preanalyze -- expression after type replacement. @@ -12747,18 +12766,19 @@ package body Sem_Ch13 is when others => if Present (Expr) then case Aspect_Argument (A_Id) is - when Expression | Optional_Expression => + when Expression + | Optional_Expression + => Analyze_And_Resolve (Expression (ASN)); - when Name | Optional_Name => + when Name + | Optional_Name + => if Nkind (Expr) = N_Identifier then Find_Direct_Name (Expr); elsif Nkind (Expr) = N_Selected_Component then Find_Selected_Component (Expr); - - else - null; end if; end case; end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index e9f6fcd1e2e..ab1e8c04fa9 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -1847,7 +1847,6 @@ package body Sem_Ch3 is when others => return False; - end case; end Contains_POC; @@ -2892,7 +2891,6 @@ package body Sem_Ch3 is when others => raise Program_Error; - end case; end if; @@ -4869,8 +4867,8 @@ package body Sem_Ch3 is case Ekind (T) is when Array_Kind => - Set_Ekind (Id, E_Array_Subtype); - Copy_Array_Subtype_Attributes (Id, T); + Set_Ekind (Id, E_Array_Subtype); + Copy_Array_Subtype_Attributes (Id, T); when Decimal_Fixed_Point_Kind => Set_Ekind (Id, E_Decimal_Fixed_Point_Subtype); @@ -4942,7 +4940,9 @@ package body Sem_Ch3 is Set_Equivalent_Type (Id, Equivalent_Type (T)); end if; - when E_Record_Type | E_Record_Subtype => + when E_Record_Subtype + | E_Record_Type + => Set_Ekind (Id, E_Record_Subtype); if Ekind (T) = E_Record_Subtype @@ -5097,7 +5097,7 @@ package body Sem_Ch3 is Set_Stored_Constraint_From_Discriminant_Constraint (Id); end if; - when Incomplete_Kind => + when Incomplete_Kind => if Ada_Version >= Ada_2005 then -- In Ada 2005 an incomplete type can be explicitly tagged: @@ -5808,9 +5808,10 @@ package body Sem_Ch3 is Set_Is_Internal (Anon); case Nkind (N) is - when N_Component_Declaration | - N_Unconstrained_Array_Definition | - N_Constrained_Array_Definition => + when N_Constrained_Array_Definition + | N_Component_Declaration + | N_Unconstrained_Array_Definition + => Comp := Component_Definition (N); Acc := Access_Definition (Comp); @@ -9103,9 +9104,10 @@ package body Sem_Ch3 is when Array_Kind => Build_Derived_Array_Type (N, Parent_Type, Derived_Type); - when E_Record_Type + when Class_Wide_Kind | E_Record_Subtype - | Class_Wide_Kind => + | E_Record_Type + => Build_Derived_Record_Type (N, Parent_Type, Derived_Type, Derive_Subps); return; @@ -11660,12 +11662,13 @@ package body Sem_Ch3 is Save_Homonym := Homonym (Priv); case Ekind (Full_Base) is - when E_Record_Type | - E_Record_Subtype | - Class_Wide_Kind | - Private_Kind | - Task_Kind | - Protected_Kind => + when Class_Wide_Kind + | Private_Kind + | Protected_Kind + | Task_Kind + | E_Record_Subtype + | E_Record_Type + => Copy_Node (Priv, Full); Set_Has_Discriminants @@ -17958,8 +17961,9 @@ package body Sem_Ch3 is is begin case T_Kind is - when Enumeration_Kind | - Integer_Kind => + when Enumeration_Kind + | Integer_Kind + => return Constraint_Kind = N_Range_Constraint; when Decimal_Fixed_Point_Kind => @@ -17974,14 +17978,15 @@ package body Sem_Ch3 is return Nkind_In (Constraint_Kind, N_Digits_Constraint, N_Range_Constraint); - when Access_Kind | - Array_Kind | - E_Record_Type | - E_Record_Subtype | - Class_Wide_Kind | - E_Incomplete_Type | - Private_Kind | - Concurrent_Kind => + when Access_Kind + | Array_Kind + | Class_Wide_Kind + | Concurrent_Kind + | Private_Kind + | E_Incomplete_Type + | E_Record_Subtype + | E_Record_Type + => return Constraint_Kind = N_Index_Or_Discriminant_Constraint; when others => @@ -18817,7 +18822,11 @@ package body Sem_Ch3 is end if; case Nkind (Original_Node (Exp)) is - when N_Aggregate | N_Extension_Aggregate | N_Function_Call | N_Op => + when N_Aggregate + | N_Extension_Aggregate + | N_Function_Call + | N_Op + => return True; when N_Identifier => @@ -18837,16 +18846,18 @@ package body Sem_Ch3 is -- A return statement for a build-in-place function returning a -- synchronized type also introduces an unchecked conversion. - when N_Type_Conversion | - N_Unchecked_Type_Conversion => + when N_Type_Conversion + | N_Unchecked_Type_Conversion + => return not Comes_From_Source (Exp) and then OK_For_Limited_Init_In_05 (Typ, Expression (Original_Node (Exp))); - when N_Indexed_Component | - N_Selected_Component | - N_Explicit_Dereference => + when N_Explicit_Dereference + | N_Indexed_Component + | N_Selected_Component + => return Nkind (Exp) = N_Function_Call; -- A use of 'Input is a function call, hence allowed. Normally the @@ -20891,10 +20902,11 @@ package body Sem_Ch3 is Constrain_Integer (Def_Id, S); Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id); - when E_Record_Type | - E_Record_Subtype | - Class_Wide_Kind | - E_Incomplete_Type => + when Class_Wide_Kind + | E_Incomplete_Type + | E_Record_Subtype + | E_Record_Type + => Constrain_Discriminated_Type (Def_Id, S, Related_Nod); if Ekind (Def_Id) = E_Incomplete_Type then diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 253a12dabbb..d2fa0a4d899 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -3656,36 +3656,40 @@ package body Sem_Ch4 is -- Otherwise action depends on operator case Op_Name is - when Name_Op_Add | - Name_Op_Subtract | - Name_Op_Multiply | - Name_Op_Divide | - Name_Op_Mod | - Name_Op_Rem | - Name_Op_Expon => + when Name_Op_Add + | Name_Op_Divide + | Name_Op_Expon + | Name_Op_Mod + | Name_Op_Multiply + | Name_Op_Rem + | Name_Op_Subtract + => Find_Arithmetic_Types (Act1, Act2, Op_Id, N); - when Name_Op_And | - Name_Op_Or | - Name_Op_Xor => + when Name_Op_And + | Name_Op_Or + | Name_Op_Xor + => Find_Boolean_Types (Act1, Act2, Op_Id, N); - when Name_Op_Lt | - Name_Op_Le | - Name_Op_Gt | - Name_Op_Ge => + when Name_Op_Ge + | Name_Op_Gt + | Name_Op_Le + | Name_Op_Lt + => Find_Comparison_Types (Act1, Act2, Op_Id, N); - when Name_Op_Eq | - Name_Op_Ne => + when Name_Op_Eq + | Name_Op_Ne + => Find_Equality_Types (Act1, Act2, Op_Id, N); - when Name_Op_Concat => + when Name_Op_Concat => Find_Concatenation_Types (Act1, Act2, Op_Id, N); -- Is this when others, or should it be an abort??? - when others => + when others => null; end case; @@ -3693,17 +3697,18 @@ package body Sem_Ch4 is else case Op_Name is - when Name_Op_Subtract | - Name_Op_Add | - Name_Op_Abs => + when Name_Op_Abs + | Name_Op_Add + | Name_Op_Subtract + => Find_Unary_Types (Act1, Op_Id, N); - when Name_Op_Not => + when Name_Op_Not => Find_Negation_Types (Act1, Op_Id, N); -- Is this when others correct, or should it be an abort??? - when others => + when others => null; end case; end if; @@ -6688,7 +6693,6 @@ package body Sem_Ch4 is -- Now test the entity we got to see if it is a bad case case Ekind (Entity (Enode)) is - when E_Package => Error_Msg_N ("package name cannot be used as operand", Enode); @@ -6713,13 +6717,15 @@ package body Sem_Ch4 is Error_Msg_N ("exception name cannot be used as operand", Enode); - when E_Block | E_Label | E_Loop => + when E_Block + | E_Label + | E_Loop + => Error_Msg_N ("label name cannot be used as operand", Enode); when others => return False; - end case; return True; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index d092134d73d..70b4a36a2b5 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -1685,8 +1685,8 @@ package body Sem_Ch6 is elsif Nkind (P) = N_Selected_Component and then Ekind_In (Entity (Selector_Name (P)), E_Entry, - E_Procedure, - E_Function) + E_Function, + E_Procedure) then Analyze_Call_And_Resolve; @@ -1702,7 +1702,7 @@ package body Sem_Ch6 is New_N := Make_Indexed_Component (Loc, - Prefix => New_Copy (P), + Prefix => New_Copy (P), Expressions => Actuals); Set_Name (N, New_N); Set_Etype (New_N, Standard_Void_Type); @@ -7690,8 +7690,9 @@ package body Sem_Ch6 is -- All but "&" and "**" have same-types parameters case Op is - when Name_Op_Concat | - Name_Op_Expon => + when Name_Op_Concat + | Name_Op_Expon + => null; when others => @@ -7703,37 +7704,42 @@ package body Sem_Ch6 is -- Check parameter and result types case Op is - when Name_Op_And | - Name_Op_Or | - Name_Op_Xor => + when Name_Op_And + | Name_Op_Or + | Name_Op_Xor + => return Is_Boolean_Type (Result_Type) and then Result_Type = Type_1; - when Name_Op_Mod | - Name_Op_Rem => + when Name_Op_Mod + | Name_Op_Rem + => return Is_Integer_Type (Result_Type) and then Result_Type = Type_1; - when Name_Op_Add | - Name_Op_Divide | - Name_Op_Multiply | - Name_Op_Subtract => + when Name_Op_Add + | Name_Op_Divide + | Name_Op_Multiply + | Name_Op_Subtract + => return Is_Numeric_Type (Result_Type) and then Result_Type = Type_1; - when Name_Op_Eq | - Name_Op_Ne => + when Name_Op_Eq + | Name_Op_Ne + => return Is_Boolean_Type (Result_Type) and then not Is_Limited_Type (Type_1); - when Name_Op_Ge | - Name_Op_Gt | - Name_Op_Le | - Name_Op_Lt => + when Name_Op_Ge + | Name_Op_Gt + | Name_Op_Le + | Name_Op_Lt + => return Is_Boolean_Type (Result_Type) and then (Is_Array_Type (Type_1) @@ -7758,9 +7764,10 @@ package body Sem_Ch6 is else case Op is - when Name_Op_Abs | - Name_Op_Add | - Name_Op_Subtract => + when Name_Op_Abs + | Name_Op_Add + | Name_Op_Subtract + => return Is_Numeric_Type (Result_Type) and then Result_Type = Type_1; @@ -8480,7 +8487,6 @@ package body Sem_Ch6 is else case Nkind (E1) is - when N_Aggregate => return FCL (Expressions (E1), Expressions (E2)) @@ -8550,7 +8556,9 @@ package body Sem_Ch6 is and then FCE (Left_Opnd (E1), Left_Opnd (E2)) and then FCE (Right_Opnd (E1), Right_Opnd (E2)); - when N_Short_Circuit | N_Membership_Test => + when N_Membership_Test + | N_Short_Circuit + => return FCE (Left_Opnd (E1), Left_Opnd (E2)) and then @@ -8777,7 +8785,6 @@ package body Sem_Ch6 is when others => return True; - end case; end if; end Fully_Conformant_Expressions; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index d237e5f0722..c81d4252767 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -2694,19 +2694,23 @@ package body Sem_Ch8 is -- operation). case Attribute_Name (Nam) is - when Name_Input => + when Name_Input => Stream_Prim := Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Input); + when Name_Output => Stream_Prim := Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Output); - when Name_Read => + + when Name_Read => Stream_Prim := Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Read); - when Name_Write => + + when Name_Write => Stream_Prim := Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Write); - when others => + + when others => Error_Msg_N ("attribute must be a primitive dispatching operation", Nam); @@ -5710,8 +5714,8 @@ package body Sem_Ch8 is -- If we don't know now, generate reference later - when Unknown => - Deferred_References.Append ((E, N)); + when Unknown => + Deferred_References.Append ((E, N)); end case; end if; end if; @@ -6254,8 +6258,10 @@ package body Sem_Ch8 is case Is_LHS (N) is when Yes => Generate_Reference (Id, N, 'm'); + when No => Generate_Reference (Id, N, 'r'); + when Unknown => Deferred_References.Append ((Id, N)); end case; @@ -7655,7 +7661,11 @@ package body Sem_Ch8 is -- contains a declaration for a derived Boolean type, or for an -- array of Boolean type. - when Name_Op_And | Name_Op_Not | Name_Op_Or | Name_Op_Xor => + when Name_Op_And + | Name_Op_Not + | Name_Op_Or + | Name_Op_Xor + => while Id /= Priv_Id loop if Valid_Boolean_Arg (Id) and then Is_Base_Type (Id) then Add_Implicit_Operator (Id); @@ -7667,7 +7677,9 @@ package body Sem_Ch8 is -- Equality: look for any non-limited type (result is Boolean) - when Name_Op_Eq | Name_Op_Ne => + when Name_Op_Eq + | Name_Op_Ne + => while Id /= Priv_Id loop if Is_Type (Id) and then not Is_Limited_Type (Id) @@ -7682,7 +7694,11 @@ package body Sem_Ch8 is -- Comparison operators: scalar type, or array of scalar - when Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge => + when Name_Op_Ge + | Name_Op_Gt + | Name_Op_Le + | Name_Op_Lt + => while Id /= Priv_Id loop if (Is_Scalar_Type (Id) or else (Is_Array_Type (Id) @@ -7698,14 +7714,15 @@ package body Sem_Ch8 is -- Arithmetic operators: any numeric type - when Name_Op_Abs | - Name_Op_Add | - Name_Op_Mod | - Name_Op_Rem | - Name_Op_Subtract | - Name_Op_Multiply | - Name_Op_Divide | - Name_Op_Expon => + when Name_Op_Abs + | Name_Op_Add + | Name_Op_Divide + | Name_Op_Expon + | Name_Op_Mod + | Name_Op_Multiply + | Name_Op_Rem + | Name_Op_Subtract + => while Id /= Priv_Id loop if Is_Numeric_Type (Id) and then Is_Base_Type (Id) then Add_Implicit_Operator (Id); @@ -7733,13 +7750,13 @@ package body Sem_Ch8 is -- What is the others condition here? Should we be using a -- subtype of Name_Id that would restrict to operators ??? - when others => null; + when others => + null; end case; -- If we fall through, then we do not have an implicit operator return False; - end Has_Implicit_Operator; ----------------------------------- diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 1c814549743..97c9335c4f6 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -292,14 +292,14 @@ package body Sem_Ch9 is pragma Assert (Nkind (Attr) = N_Attribute_Reference); case Attribute_Name (Attr) is - when Name_Min | - Name_Max | - Name_Pred | - Name_Succ | - Name_Value | - Name_Wide_Value | - Name_Wide_Wide_Value => - + when Name_Max + | Name_Min + | Name_Pred + | Name_Succ + | Name_Value + | Name_Wide_Value + | Name_Wide_Wide_Value + => -- A language-defined attribute denotes a static -- function if the prefix denotes a static scalar -- subtype, and if the parameter and result types @@ -326,7 +326,8 @@ package body Sem_Ch9 is return False; end if; - when others => return False; + when others => + return False; end case; end Is_Static_Function; @@ -892,13 +893,18 @@ package body Sem_Ch9 is loop P := Parent (P); case Nkind (P) is - when N_Task_Body | N_Compilation_Unit => + when N_Compilation_Unit + | N_Task_Body + => exit; + when N_Asynchronous_Select => - Error_Msg_N ("accept statements are not allowed within" & - " an asynchronous select inner" & - " to the enclosing task body", N); + Error_Msg_N + ("accept statements are not allowed within an " + & "asynchronous select inner to the enclosing task body", + N); exit; + when others => null; end case; diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index 2bdf9e5a2c4..44794ba1e0a 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -1147,22 +1147,23 @@ package body Sem_Dim is when N_Extended_Return_Statement => Analyze_Dimension_Extended_Return_Statement (N); - when N_Attribute_Reference | - N_Expanded_Name | - N_Explicit_Dereference | - N_Function_Call | - N_Indexed_Component | - N_Qualified_Expression | - N_Selected_Component | - N_Slice | - N_Type_Conversion | - N_Unchecked_Type_Conversion => + when N_Attribute_Reference + | N_Expanded_Name + | N_Explicit_Dereference + | N_Function_Call + | N_Indexed_Component + | N_Qualified_Expression + | N_Selected_Component + | N_Slice + | N_Type_Conversion + | N_Unchecked_Type_Conversion + => Analyze_Dimension_Has_Etype (N); -- In the presence of a repaired syntax error, an identifier -- may be introduced without a usable type. - when N_Identifier => + when N_Identifier => if Present (Etype (N)) then Analyze_Dimension_Has_Etype (N); end if; @@ -1187,8 +1188,8 @@ package body Sem_Dim is when N_Unary_Op => Analyze_Dimension_Unary_Op (N); - when others => null; - + when others => + null; end case; end Analyze_Dimension; @@ -2021,11 +2022,13 @@ package body Sem_Dim is -- table from growing uselessly. case Nkind (N) is - when N_Attribute_Reference | - N_Indexed_Component => + when N_Attribute_Reference + | N_Indexed_Component + => declare - Expr : Node_Id; Exprs : constant List_Id := Expressions (N); + Expr : Node_Id; + begin if Present (Exprs) then Expr := First (Exprs); @@ -2036,15 +2039,17 @@ package body Sem_Dim is end if; end; - when N_Qualified_Expression | - N_Type_Conversion | - N_Unchecked_Type_Conversion => + when N_Qualified_Expression + | N_Type_Conversion + | N_Unchecked_Type_Conversion + => Remove_Dimensions (Expression (N)); when N_Selected_Component => Remove_Dimensions (Selector_Name (N)); - when others => null; + when others => + null; end case; end Analyze_Dimension_Has_Etype; @@ -2273,18 +2278,21 @@ package body Sem_Dim is procedure Analyze_Dimension_Unary_Op (N : Node_Id) is begin case Nkind (N) is - when N_Op_Plus | N_Op_Minus | N_Op_Abs => - -- Propagate the dimension if the operand is not dimensionless + -- Propagate the dimension if the operand is not dimensionless + when N_Op_Abs + | N_Op_Minus + | N_Op_Plus + => declare R : constant Node_Id := Right_Opnd (N); begin Move_Dimensions (R, N); end; - when others => null; - + when others => + null; end case; end Analyze_Dimension_Unary_Op; @@ -3502,22 +3510,14 @@ package body Sem_Dim is function Belong_To_Numeric_Literal (C : Character) return Boolean is begin case C is - when '0' .. '9' | - '_' | - '.' | - 'e' | - '#' | - 'A' | - 'B' | - 'C' | - 'D' | - 'E' | - 'F' => + when '0' .. '9' + | '_' | '.' | 'e' | '#' | 'A' | 'B' | 'C' | 'D' | 'E' | 'F' + => return True; -- Make sure '+' or '-' is part of an exponent. - when '+' | '-' => + when '+' | '-' => declare Prev_C : constant Character := Sbuffer (Src_Ptr - 1); begin @@ -3526,7 +3526,7 @@ package body Sem_Dim is -- All other character doesn't belong to a numeric literal - when others => + when others => return False; end case; end Belong_To_Numeric_Literal; diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb index 5bb273bab2a..fe94150816c 100644 --- a/gcc/ada/sem_dist.adb +++ b/gcc/ada/sem_dist.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. -- -- -- -- 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- -- @@ -272,15 +272,19 @@ package body Sem_Dist is --------------------------------- function Is_RACW_Stub_Type_Operation (Op : Entity_Id) return Boolean is - Dispatching_Type : Entity_Id; + Typ : Entity_Id; begin case Ekind (Op) is - when E_Function | E_Procedure => - Dispatching_Type := Find_Dispatching_Type (Op); - return Present (Dispatching_Type) - and then Is_RACW_Stub_Type (Dispatching_Type) - and then not Is_Internal (Op); + when E_Function + | E_Procedure + => + Typ := Find_Dispatching_Type (Op); + + return + Present (Typ) + and then Is_RACW_Stub_Type (Typ) + and then not Is_Internal (Op); when others => return False; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index f98498d9ed3..936c1c3f559 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -3430,9 +3430,7 @@ package body Sem_Eval is when N_Op_Le => Result := (Left_Real <= Right_Real); when N_Op_Gt => Result := (Left_Real > Right_Real); when N_Op_Ge => Result := (Left_Real >= Right_Real); - - when others => - raise Program_Error; + when others => raise Program_Error; end case; Fold_Uint (N, Test (Result), True); @@ -6522,7 +6520,10 @@ package body Sem_Eval is -- Entity name - when N_Expanded_Name | N_Identifier | N_Operator_Symbol => + when N_Expanded_Name + | N_Identifier + | N_Operator_Symbol + => E := Entity (N); if Is_Named_Number (E) then @@ -6596,10 +6597,13 @@ package body Sem_Eval is -- Binary operator - when N_Binary_Op | N_Short_Circuit | N_Membership_Test => + when N_Binary_Op + | N_Membership_Test + | N_Short_Circuit + => if Nkind (N) in N_Op_Shift then Error_Msg_N - ("!shift functions are never static (RM 4.9(6,18))", N); + ("!shift functions are never static (RM 4.9(6,18))", N); else Why_Not_Static (Left_Opnd (N)); Why_Not_Static (Right_Opnd (N)); @@ -6718,7 +6722,9 @@ package body Sem_Eval is -- Aggregate - when N_Aggregate | N_Extension_Aggregate => + when N_Aggregate + | N_Extension_Aggregate + => Error_Msg_N ("!an aggregate is never static (RM 4.9)", N); -- Range @@ -6768,7 +6774,6 @@ package body Sem_Eval is when others => null; - end case; end Why_Not_Static; diff --git a/gcc/ada/sem_mech.adb b/gcc/ada/sem_mech.adb index cfe9f9536c1..b28562e0500 100644 --- a/gcc/ada/sem_mech.adb +++ b/gcc/ada/sem_mech.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-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- -- @@ -146,12 +146,12 @@ package body Sem_Mech is -- the point of view of parameter passing mechanism. Convention -- Ghost has the same dynamic semantics as convention Ada. - when Convention_Ada | - Convention_Intrinsic | - Convention_Entry | - Convention_Protected | - Convention_Stubbed => - + when Convention_Ada + | Convention_Entry + | Convention_Intrinsic + | Convention_Protected + | Convention_Stubbed + => -- By reference types are passed by reference (RM 6.2(4)) if Is_By_Reference_Type (Typ) then @@ -183,11 +183,11 @@ package body Sem_Mech is -- Note: Assembler, C++, Stdcall also use C conventions - when Convention_Assembler | - Convention_C | - Convention_CPP | - Convention_Stdcall => - + when Convention_Assembler + | Convention_C + | Convention_CPP + | Convention_Stdcall + => -- The following values are passed by copy -- IN Scalar parameters (RM B.3(66)) diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 1fc6f76cc6a..87228eb888b 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -9003,8 +9003,10 @@ package body Sem_Prag is case Status is when Suppressed => Set_Is_Inlined (Subp, False); + when Disabled => null; + when Enabled => if not Has_Pragma_No_Inline (Subp) then Set_Is_Inlined (Subp, True); @@ -10390,10 +10392,13 @@ package body Sem_Prag is case Opt.Uneval_Old is when 'A' => Set_Uneval_Old_Accept (N); + when 'E' => null; + when 'W' => Set_Uneval_Old_Warn (N); + when others => raise Program_Error; end case; @@ -11371,7 +11376,10 @@ package body Sem_Prag is -- otherwise legal pre-Ada_2005 programs. The one argument form is -- intended for exclusive use in the GNAT run-time library. - when Pragma_Ada_05 | Pragma_Ada_2005 => declare + when Pragma_Ada_05 + | Pragma_Ada_2005 + => + declare E_Id : Node_Id; begin @@ -11432,7 +11440,10 @@ package body Sem_Prag is -- otherwise legal pre-Ada_2012 programs. The one argument form is -- intended for exclusive use in the GNAT run-time library. - when Pragma_Ada_12 | Pragma_Ada_2012 => declare + when Pragma_Ada_12 + | Pragma_Ada_2012 + => + declare E_Id : Node_Id; begin @@ -11648,10 +11659,11 @@ package body Sem_Prag is -- ( [Check => ] Boolean_EXPRESSION -- [, [Message =>] Static_String_EXPRESSION]); - when Pragma_Assert | - Pragma_Assert_And_Cut | - Pragma_Assume | - Pragma_Loop_Invariant => + when Pragma_Assert + | Pragma_Assert_And_Cut + | Pragma_Assume + | Pragma_Loop_Invariant + => Assert : declare function Contains_Loop_Entry (Expr : Node_Id) return Boolean; -- Determine whether expression Expr contains a Loop_Entry @@ -12083,10 +12095,11 @@ package body Sem_Prag is -- pragma Effective_Reads [ (boolean_EXPRESSION) ]; -- pragma Effective_Writes [ (boolean_EXPRESSION) ]; - when Pragma_Async_Readers | - Pragma_Async_Writers | - Pragma_Effective_Reads | - Pragma_Effective_Writes => + when Pragma_Async_Readers + | Pragma_Async_Writers + | Pragma_Effective_Reads + | Pragma_Effective_Writes + => Async_Effective : declare Obj_Decl : Node_Id; Obj_Id : Entity_Id; @@ -12305,8 +12318,9 @@ package body Sem_Prag is -- This processing is shared by Volatile_Components - when Pragma_Atomic_Components | - Pragma_Volatile_Components => + when Pragma_Atomic_Components + | Pragma_Volatile_Components + => Atomic_Components : declare D : Node_Id; E : Entity_Id; @@ -12947,7 +12961,9 @@ package body Sem_Prag is -- older run-times that use this pragma. That's an unusual case, but -- it's easy enough to handle, so why not? - when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning => + when Pragma_Compiler_Unit + | Pragma_Compiler_Unit_Warning + => GNAT_Pragma; Check_Arg_Count (0); @@ -13362,6 +13378,7 @@ package body Sem_Prag is E : Entity_Id; pragma Warnings (Off, C); pragma Warnings (Off, E); + begin Check_Arg_Order ((Name_Convention, Name_Entity)); Check_Ada_83_Warning; @@ -13411,8 +13428,7 @@ package body Sem_Prag is -- pragma CPP_Class ([Entity =>] LOCAL_NAME) - when Pragma_CPP_Class => CPP_Class : declare - begin + when Pragma_CPP_Class => GNAT_Pragma; if Warn_On_Obsolescent_Feature then @@ -13431,7 +13447,6 @@ package body Sem_Prag is Expression => Make_Identifier (Loc, Name_CPP)), New_Copy (First (Pragma_Argument_Associations (N)))))); Analyze (N); - end CPP_Class; --------------------- -- CPP_Constructor -- @@ -13536,8 +13551,7 @@ package body Sem_Prag is -- CPP_Virtual -- ----------------- - when Pragma_CPP_Virtual => CPP_Virtual : declare - begin + when Pragma_CPP_Virtual => GNAT_Pragma; if Warn_On_Obsolescent_Feature then @@ -13545,14 +13559,12 @@ package body Sem_Prag is ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no " & "effect?j?", N); end if; - end CPP_Virtual; ---------------- -- CPP_Vtable -- ---------------- - when Pragma_CPP_Vtable => CPP_Vtable : declare - begin + when Pragma_CPP_Vtable => GNAT_Pragma; if Warn_On_Obsolescent_Feature then @@ -13560,7 +13572,6 @@ package body Sem_Prag is ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no " & "effect?j?", N); end if; - end CPP_Vtable; --------- -- CPU -- @@ -14903,8 +14914,7 @@ package body Sem_Prag is -- pragma Extend_System ([Name =>] Identifier); - when Pragma_Extend_System => Extend_System : declare - begin + when Pragma_Extend_System => GNAT_Pragma; Check_Valid_Configuration_Pragma; Check_Arg_Count (1); @@ -14936,7 +14946,6 @@ package body Sem_Prag is else Error_Pragma ("incorrect name for pragma%, must be Aux_xxx"); end if; - end Extend_System; ------------------------ -- Extensions_Allowed -- @@ -15149,8 +15158,7 @@ package body Sem_Prag is -- UPPERCASE | LOWERCASE -- [, AS_IS | UPPERCASE | LOWERCASE]); - when Pragma_External_Name_Casing => External_Name_Casing : declare - begin + when Pragma_External_Name_Casing => GNAT_Pragma; Check_No_Identifiers; @@ -15188,7 +15196,6 @@ package body Sem_Prag is when others => null; end case; - end External_Name_Casing; --------------- -- Fast_Math -- @@ -15625,7 +15632,10 @@ package body Sem_Prag is -- Note: pragma Comment shares this processing. Pragma Ident is -- identical in effect to pragma Commment. - when Pragma_Ident | Pragma_Comment => Ident : declare + when Pragma_Comment + | Pragma_Ident + => + Ident : declare Str : Node_Id; begin @@ -17141,8 +17151,9 @@ package body Sem_Prag is -- pragma Linker_Destructor (procedure_LOCAL_NAME); - when Pragma_Linker_Constructor | - Pragma_Linker_Destructor => + when Pragma_Linker_Constructor + | Pragma_Linker_Destructor + => Linker_Constructor : declare Arg1_X : Node_Id; Proc : Entity_Id; @@ -17247,7 +17258,10 @@ package body Sem_Prag is -- all we need to do is to set the Linker_Section_pragma field, -- checking that we do not have a duplicate. - when E_Constant | E_Variable | Type_Kind => + when Type_Kind + | E_Constant + | E_Variable + => LPE := Linker_Section_Pragma (Ent); if Present (LPE) then @@ -17416,12 +17430,9 @@ package body Sem_Prag is LP_Val := Chars (Get_Pragma_Arg (Arg1)); case LP_Val is - when Name_Ceiling_Locking => - LP := 'C'; - when Name_Inheritance_Locking => - LP := 'I'; - when Name_Concurrent_Readers_Locking => - LP := 'R'; + when Name_Ceiling_Locking => LP := 'C'; + when Name_Concurrent_Readers_Locking => LP := 'R'; + when Name_Inheritance_Locking => LP := 'I'; end case; if Locking_Policy /= ' ' @@ -18338,12 +18349,10 @@ package body Sem_Prag is Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1)); begin case Nam is - when Name_Time => - Opt.Optimize_Alignment := 'T'; - when Name_Space => - Opt.Optimize_Alignment := 'S'; - when Name_Off => - Opt.Optimize_Alignment := 'O'; + when Name_Off => Opt.Optimize_Alignment := 'O'; + when Name_Space => Opt.Optimize_Alignment := 'S'; + when Name_Time => Opt.Optimize_Alignment := 'T'; + when others => Error_Pragma_Arg ("invalid argument for pragma%", Arg1); end case; @@ -18816,7 +18825,7 @@ package body Sem_Prag is -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER); - when Pragma_Partition_Elaboration_Policy => declare + when Pragma_Partition_Elaboration_Policy => PEP : declare subtype PEP_Range is Name_Id range First_Partition_Elaboration_Policy_Name .. Last_Partition_Elaboration_Policy_Name; @@ -18832,10 +18841,8 @@ package body Sem_Prag is PEP_Val := Chars (Get_Pragma_Arg (Arg1)); case PEP_Val is - when Name_Concurrent => - PEP := 'C'; - when Name_Sequential => - PEP := 'S'; + when Name_Concurrent => PEP := 'C'; + when Name_Sequential => PEP := 'S'; end case; if Partition_Elaboration_Policy /= ' ' @@ -18855,7 +18862,7 @@ package body Sem_Prag is Partition_Elaboration_Policy_Sloc := Loc; end if; end if; - end; + end PEP; ------------- -- Passive -- @@ -19125,9 +19132,10 @@ package body Sem_Prag is -- the "pragma on subprogram declaration" case. In that scenario -- the annotation must instantiate itself. - when Pragma_Post | - Pragma_Post_Class | - Pragma_Postcondition => + when Pragma_Post + | Pragma_Post_Class + | Pragma_Postcondition + => Analyze_Pre_Post_Condition; -------------------------------- @@ -19171,9 +19179,10 @@ package body Sem_Prag is -- the "pragma on subprogram declaration" case. In that scenario -- the annotation must instantiate itself. - when Pragma_Pre | - Pragma_Pre_Class | - Pragma_Precondition => + when Pragma_Pre + | Pragma_Pre_Class + | Pragma_Precondition + => Analyze_Pre_Post_Condition; --------------- @@ -19788,7 +19797,9 @@ package body Sem_Prag is -- [, [External =>] EXTERNAL_SYMBOL] -- [, [Size =>] EXTERNAL_SYMBOL]); - when Pragma_Psect_Object | Pragma_Common_Object => + when Pragma_Common_Object + | Pragma_Psect_Object + => Psect_Object : declare Args : Args_List (1 .. 3); Names : constant Name_List (1 .. 3) := ( @@ -21659,7 +21670,6 @@ package body Sem_Prag is -- [Write =>] function NAME); when Pragma_Stream_Convert => Stream_Convert : declare - procedure Check_OK_Stream_Convert_Function (Arg : Node_Id); -- Check that the given argument is the name of a local function -- of one argument that is not overloaded earlier in the current @@ -22560,8 +22570,9 @@ package body Sem_Prag is -- ([Entity =>] type_LOCAL_NAME, -- [Check =>] EXPRESSION); - when Pragma_Type_Invariant | - Pragma_Type_Invariant_Class => + when Pragma_Type_Invariant + | Pragma_Type_Invariant_Class + => Type_Invariant : declare I_Pragma : Node_Id; @@ -26996,11 +27007,15 @@ package body Sem_Prag is Policy := Chars (Get_Pragma_Arg (Last (PPA))); case Policy is - when Name_Off | Name_Ignore => + when Name_Ignore + | Name_Off + => Set_Is_Ignored (N, True); Set_Is_Checked (N, False); - when Name_On | Name_Check => + when Name_Check + | Name_On + => Set_Is_Checked (N, True); Set_Is_Ignored (N, False); @@ -27116,12 +27131,19 @@ package body Sem_Prag is Name_Loop_Variant)) then case (Chars (Get_Pragma_Arg (Last (PPA)))) is - when Name_On | Name_Check => + when Name_Check + | Name_On + => return Name_Check; - when Name_Off | Name_Ignore => + + when Name_Ignore + | Name_Off + => return Name_Ignore; + when Name_Disable => return Name_Disable; + when others => raise Program_Error; end case; @@ -28993,37 +29015,40 @@ package body Sem_Prag is when -- RM defined - Name_Assert | - Name_Assertion_Policy | - Name_Static_Predicate | - Name_Dynamic_Predicate | - Name_Pre | - Name_uPre | - Name_Post | - Name_uPost | - Name_Type_Invariant | - Name_uType_Invariant | + Name_Assert + | Name_Assertion_Policy + | Name_Static_Predicate + | Name_Dynamic_Predicate + | Name_Pre + | Name_uPre + | Name_Post + | Name_uPost + | Name_Type_Invariant + | Name_uType_Invariant -- Impl defined - Name_Assert_And_Cut | - Name_Assume | - Name_Contract_Cases | - Name_Debug | - Name_Default_Initial_Condition | - Name_Ghost | - Name_Initial_Condition | - Name_Invariant | - Name_uInvariant | - Name_Loop_Invariant | - Name_Loop_Variant | - Name_Postcondition | - Name_Precondition | - Name_Predicate | - Name_Refined_Post | - Name_Statement_Assertions => return True; - - when others => return False; + | Name_Assert_And_Cut + | Name_Assume + | Name_Contract_Cases + | Name_Debug + | Name_Default_Initial_Condition + | Name_Ghost + | Name_Initial_Condition + | Name_Invariant + | Name_uInvariant + | Name_Loop_Invariant + | Name_Loop_Variant + | Name_Postcondition + | Name_Precondition + | Name_Predicate + | Name_Refined_Post + | Name_Statement_Assertions + => + return True; + + when others => + return False; end case; end Is_Valid_Assertion_Kind; @@ -29425,12 +29450,16 @@ package body Sem_Prag is case Chars (Prefix (N)) is when Name_Pre => Nam := Name_uPre; + when Name_Post => Nam := Name_uPost; + when Name_Type_Invariant => Nam := Name_uType_Invariant; + when Name_Invariant => Nam := Name_uInvariant; + when others => return; end case; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 5bc6336d5e9..2a8baaa6c08 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -1410,7 +1410,7 @@ package body Sem_Res is Opnd_Type := Base_Type (Typ); elsif (Scope (Opnd_Type) = Standard_Standard - and then Is_Binary) + and then Is_Binary) or else (Nkind (Right_Opnd (Op_Node)) = N_Attribute_Reference and then Is_Binary and then not Comes_From_Source (Opnd_Type)) @@ -1424,7 +1424,6 @@ package body Sem_Res is -- the given literal. Optimize the case where Pack is Standard. if Pack /= Standard_Standard then - if Opnd_Type = Universal_Integer then Orig_Type := Type_In_P (Is_Integer_Type'Access); @@ -1576,11 +1575,20 @@ package body Sem_Res is if Is_Private_Type (Typ) then case Nkind (N) is - when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide | - N_Op_Expon | N_Op_Mod | N_Op_Rem => + when N_Op_Add + | N_Op_Divide + | N_Op_Expon + | N_Op_Mod + | N_Op_Multiply + | N_Op_Rem + | N_Op_Subtract + => Resolve_Intrinsic_Operator (N, Typ); - when N_Op_Plus | N_Op_Minus | N_Op_Abs => + when N_Op_Abs + | N_Op_Minus + | N_Op_Plus + => Resolve_Intrinsic_Unary_Operator (N, Typ); when others => @@ -2840,122 +2848,148 @@ package body Sem_Res is end if; case N_Subexpr'(Nkind (N)) is - when N_Aggregate => Resolve_Aggregate (N, Ctx_Type); - - when N_Allocator => Resolve_Allocator (N, Ctx_Type); + when N_Aggregate => + Resolve_Aggregate (N, Ctx_Type); - when N_Short_Circuit - => Resolve_Short_Circuit (N, Ctx_Type); + when N_Allocator => + Resolve_Allocator (N, Ctx_Type); - when N_Attribute_Reference - => Resolve_Attribute (N, Ctx_Type); + when N_Short_Circuit => + Resolve_Short_Circuit (N, Ctx_Type); - when N_Case_Expression - => Resolve_Case_Expression (N, Ctx_Type); + when N_Attribute_Reference => + Resolve_Attribute (N, Ctx_Type); - when N_Character_Literal - => Resolve_Character_Literal (N, Ctx_Type); + when N_Case_Expression => + Resolve_Case_Expression (N, Ctx_Type); - when N_Expanded_Name - => Resolve_Entity_Name (N, Ctx_Type); + when N_Character_Literal => + Resolve_Character_Literal (N, Ctx_Type); - when N_Explicit_Dereference - => Resolve_Explicit_Dereference (N, Ctx_Type); + when N_Expanded_Name => + Resolve_Entity_Name (N, Ctx_Type); - when N_Expression_With_Actions - => Resolve_Expression_With_Actions (N, Ctx_Type); + when N_Explicit_Dereference => + Resolve_Explicit_Dereference (N, Ctx_Type); - when N_Extension_Aggregate - => Resolve_Extension_Aggregate (N, Ctx_Type); + when N_Expression_With_Actions => + Resolve_Expression_With_Actions (N, Ctx_Type); - when N_Function_Call - => Resolve_Call (N, Ctx_Type); + when N_Extension_Aggregate => + Resolve_Extension_Aggregate (N, Ctx_Type); - when N_Identifier - => Resolve_Entity_Name (N, Ctx_Type); + when N_Function_Call => + Resolve_Call (N, Ctx_Type); - when N_If_Expression - => Resolve_If_Expression (N, Ctx_Type); + when N_Identifier => + Resolve_Entity_Name (N, Ctx_Type); - when N_Indexed_Component - => Resolve_Indexed_Component (N, Ctx_Type); + when N_If_Expression => + Resolve_If_Expression (N, Ctx_Type); - when N_Integer_Literal - => Resolve_Integer_Literal (N, Ctx_Type); + when N_Indexed_Component => + Resolve_Indexed_Component (N, Ctx_Type); - when N_Membership_Test - => Resolve_Membership_Op (N, Ctx_Type); + when N_Integer_Literal => + Resolve_Integer_Literal (N, Ctx_Type); - when N_Null => Resolve_Null (N, Ctx_Type); + when N_Membership_Test => + Resolve_Membership_Op (N, Ctx_Type); - when N_Op_And | N_Op_Or | N_Op_Xor - => Resolve_Logical_Op (N, Ctx_Type); + when N_Null => + Resolve_Null (N, Ctx_Type); - when N_Op_Eq | N_Op_Ne - => Resolve_Equality_Op (N, Ctx_Type); + when N_Op_And + | N_Op_Or + | N_Op_Xor + => + Resolve_Logical_Op (N, Ctx_Type); - when N_Op_Lt | N_Op_Le | N_Op_Gt | N_Op_Ge - => Resolve_Comparison_Op (N, Ctx_Type); + when N_Op_Eq + | N_Op_Ne + => + Resolve_Equality_Op (N, Ctx_Type); - when N_Op_Not => Resolve_Op_Not (N, Ctx_Type); + when N_Op_Ge + | N_Op_Gt + | N_Op_Le + | N_Op_Lt + => + Resolve_Comparison_Op (N, Ctx_Type); - when N_Op_Add | N_Op_Subtract | N_Op_Multiply | - N_Op_Divide | N_Op_Mod | N_Op_Rem + when N_Op_Not => + Resolve_Op_Not (N, Ctx_Type); - => Resolve_Arithmetic_Op (N, Ctx_Type); + when N_Op_Add + | N_Op_Divide + | N_Op_Mod + | N_Op_Multiply + | N_Op_Rem + | N_Op_Subtract + => + Resolve_Arithmetic_Op (N, Ctx_Type); - when N_Op_Concat => Resolve_Op_Concat (N, Ctx_Type); + when N_Op_Concat => + Resolve_Op_Concat (N, Ctx_Type); - when N_Op_Expon => Resolve_Op_Expon (N, Ctx_Type); + when N_Op_Expon => + Resolve_Op_Expon (N, Ctx_Type); - when N_Op_Plus | N_Op_Minus | N_Op_Abs - => Resolve_Unary_Op (N, Ctx_Type); + when N_Op_Abs + | N_Op_Minus + | N_Op_Plus + => + Resolve_Unary_Op (N, Ctx_Type); - when N_Op_Shift => Resolve_Shift (N, Ctx_Type); + when N_Op_Shift => + Resolve_Shift (N, Ctx_Type); - when N_Procedure_Call_Statement - => Resolve_Call (N, Ctx_Type); + when N_Procedure_Call_Statement => + Resolve_Call (N, Ctx_Type); - when N_Operator_Symbol - => Resolve_Operator_Symbol (N, Ctx_Type); + when N_Operator_Symbol => + Resolve_Operator_Symbol (N, Ctx_Type); - when N_Qualified_Expression - => Resolve_Qualified_Expression (N, Ctx_Type); + when N_Qualified_Expression => + Resolve_Qualified_Expression (N, Ctx_Type); -- Why is the following null, needs a comment ??? - when N_Quantified_Expression - => null; + when N_Quantified_Expression => + null; - when N_Raise_Expression - => Resolve_Raise_Expression (N, Ctx_Type); + when N_Raise_Expression => + Resolve_Raise_Expression (N, Ctx_Type); - when N_Raise_xxx_Error - => Set_Etype (N, Ctx_Type); + when N_Raise_xxx_Error => + Set_Etype (N, Ctx_Type); - when N_Range => Resolve_Range (N, Ctx_Type); + when N_Range => + Resolve_Range (N, Ctx_Type); - when N_Real_Literal - => Resolve_Real_Literal (N, Ctx_Type); + when N_Real_Literal => + Resolve_Real_Literal (N, Ctx_Type); - when N_Reference => Resolve_Reference (N, Ctx_Type); + when N_Reference => + Resolve_Reference (N, Ctx_Type); - when N_Selected_Component - => Resolve_Selected_Component (N, Ctx_Type); + when N_Selected_Component => + Resolve_Selected_Component (N, Ctx_Type); - when N_Slice => Resolve_Slice (N, Ctx_Type); + when N_Slice => + Resolve_Slice (N, Ctx_Type); - when N_String_Literal - => Resolve_String_Literal (N, Ctx_Type); + when N_String_Literal => + Resolve_String_Literal (N, Ctx_Type); - when N_Type_Conversion - => Resolve_Type_Conversion (N, Ctx_Type); + when N_Type_Conversion => + Resolve_Type_Conversion (N, Ctx_Type); when N_Unchecked_Expression => - Resolve_Unchecked_Expression (N, Ctx_Type); + Resolve_Unchecked_Expression (N, Ctx_Type); when N_Unchecked_Type_Conversion => - Resolve_Unchecked_Type_Conversion (N, Ctx_Type); + Resolve_Unchecked_Type_Conversion (N, Ctx_Type); end case; -- Ada 2012 (AI05-0149): Apply an (implicit) conversion to an @@ -9303,20 +9337,20 @@ package body Sem_Res is else case Nkind (Parent (N)) is - when N_Op_And | - N_Op_Eq | - N_Op_Ge | - N_Op_Gt | - N_Op_Le | - N_Op_Lt | - N_Op_Ne | - N_Op_Or | - N_Op_Xor | - N_In | - N_Not_In | - N_And_Then | - N_Or_Else => - + when N_And_Then + | N_In + | N_Not_In + | N_Op_And + | N_Op_Eq + | N_Op_Ge + | N_Op_Gt + | N_Op_Le + | N_Op_Lt + | N_Op_Ne + | N_Op_Or + | N_Op_Xor + | N_Or_Else + => return Left_Opnd (Parent (N)) = N; when others => @@ -11312,11 +11346,20 @@ package body Sem_Res is if Is_Intrinsic_Subprogram (Op) and then Is_Private_Type (Typ) then case Nkind (N) is - when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide | - N_Op_Expon | N_Op_Mod | N_Op_Rem => + when N_Op_Add + | N_Op_Divide + | N_Op_Expon + | N_Op_Mod + | N_Op_Multiply + | N_Op_Rem + | N_Op_Subtract + => Resolve_Intrinsic_Operator (N, Typ); - when N_Op_Plus | N_Op_Minus | N_Op_Abs => + when N_Op_Abs + | N_Op_Minus + | N_Op_Plus + => Resolve_Intrinsic_Unary_Operator (N, Typ); when others => diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index f9efdab2c0d..3b90fe82c7e 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1663,9 +1663,9 @@ package body Sem_Util is return Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); end if; - when N_Op_Divide | - N_Op_Mod | - N_Op_Rem + when N_Op_Divide + | N_Op_Mod + | N_Op_Rem => if Do_Division_Check (Expr) or else @@ -1679,25 +1679,25 @@ package body Sem_Util is Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); end if; - when N_Op_Add | - N_Op_And | - N_Op_Concat | - N_Op_Eq | - N_Op_Expon | - N_Op_Ge | - N_Op_Gt | - N_Op_Le | - N_Op_Lt | - N_Op_Multiply | - N_Op_Ne | - N_Op_Or | - 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 + when N_Op_Add + | N_Op_And + | N_Op_Concat + | N_Op_Eq + | N_Op_Expon + | N_Op_Ge + | N_Op_Gt + | N_Op_Le + | N_Op_Lt + | N_Op_Multiply + | N_Op_Ne + | N_Op_Or + | 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 => if Do_Overflow_Check (Expr) then return False; @@ -2272,7 +2272,9 @@ package body Sem_Util is Collect_Identifiers (Low_Bound (N)); Collect_Identifiers (High_Bound (N)); - when N_Op | N_Membership_Test => + when N_Membership_Test + | N_Op + => declare Expr : Node_Id; @@ -2349,8 +2351,9 @@ package body Sem_Util is end loop; end; - when N_Subprogram_Call | - N_Entry_Call_Statement => + when N_Entry_Call_Statement + | N_Subprogram_Call + => declare Id : constant Entity_Id := Get_Function_Id (N); Formal : Node_Id; @@ -2371,8 +2374,9 @@ package body Sem_Util is end loop; end; - when N_Aggregate | - N_Extension_Aggregate => + when N_Aggregate + | N_Extension_Aggregate + => declare Assoc : Node_Id; Choice : Node_Id; @@ -2681,16 +2685,19 @@ package body Sem_Util is while Present (Elmt_2) loop if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then case Nkind (Parent (Node (Elmt_2))) is - when N_Aggregate | - N_Component_Association | - N_Component_Declaration => + when N_Aggregate + | N_Component_Association + | N_Component_Declaration + => Error_Msg_N ("value may be affected by call in other " & "component because they are evaluated " & "in unspecified order", Node (Elmt_2)); - when N_In | N_Not_In => + when N_In + | N_Not_In + => Error_Msg_N ("value may be affected by call in other " & "alternative because they are evaluated " @@ -5183,67 +5190,67 @@ package body Sem_Util is begin case Nkind (N) is - when N_Abstract_Subprogram_Declaration | - N_Expression_Function | - N_Formal_Subprogram_Declaration | - N_Generic_Package_Declaration | - N_Generic_Subprogram_Declaration | - N_Package_Declaration | - N_Subprogram_Body | - N_Subprogram_Body_Stub | - N_Subprogram_Declaration | - N_Subprogram_Renaming_Declaration + when N_Abstract_Subprogram_Declaration + | N_Expression_Function + | N_Formal_Subprogram_Declaration + | N_Generic_Package_Declaration + | N_Generic_Subprogram_Declaration + | N_Package_Declaration + | N_Subprogram_Body + | N_Subprogram_Body_Stub + | N_Subprogram_Declaration + | N_Subprogram_Renaming_Declaration => return Defining_Entity (Specification (N)); - when N_Component_Declaration | - N_Defining_Program_Unit_Name | - N_Discriminant_Specification | - N_Entry_Body | - N_Entry_Declaration | - N_Entry_Index_Specification | - N_Exception_Declaration | - N_Exception_Renaming_Declaration | - N_Formal_Object_Declaration | - N_Formal_Package_Declaration | - N_Formal_Type_Declaration | - N_Full_Type_Declaration | - N_Implicit_Label_Declaration | - N_Incomplete_Type_Declaration | - N_Loop_Parameter_Specification | - N_Number_Declaration | - N_Object_Declaration | - N_Object_Renaming_Declaration | - N_Package_Body_Stub | - N_Parameter_Specification | - N_Private_Extension_Declaration | - N_Private_Type_Declaration | - N_Protected_Body | - N_Protected_Body_Stub | - N_Protected_Type_Declaration | - N_Single_Protected_Declaration | - N_Single_Task_Declaration | - N_Subtype_Declaration | - N_Task_Body | - N_Task_Body_Stub | - N_Task_Type_Declaration + when N_Component_Declaration + | N_Defining_Program_Unit_Name + | N_Discriminant_Specification + | N_Entry_Body + | N_Entry_Declaration + | N_Entry_Index_Specification + | N_Exception_Declaration + | N_Exception_Renaming_Declaration + | N_Formal_Object_Declaration + | N_Formal_Package_Declaration + | N_Formal_Type_Declaration + | N_Full_Type_Declaration + | N_Implicit_Label_Declaration + | N_Incomplete_Type_Declaration + | N_Loop_Parameter_Specification + | N_Number_Declaration + | N_Object_Declaration + | N_Object_Renaming_Declaration + | N_Package_Body_Stub + | N_Parameter_Specification + | N_Private_Extension_Declaration + | N_Private_Type_Declaration + | N_Protected_Body + | N_Protected_Body_Stub + | N_Protected_Type_Declaration + | N_Single_Protected_Declaration + | N_Single_Task_Declaration + | N_Subtype_Declaration + | N_Task_Body + | N_Task_Body_Stub + | N_Task_Type_Declaration => return Defining_Identifier (N); when N_Subunit => return Defining_Entity (Proper_Body (N)); - when N_Function_Instantiation | - N_Function_Specification | - N_Generic_Function_Renaming_Declaration | - N_Generic_Package_Renaming_Declaration | - N_Generic_Procedure_Renaming_Declaration | - N_Package_Body | - N_Package_Instantiation | - N_Package_Renaming_Declaration | - N_Package_Specification | - N_Procedure_Instantiation | - N_Procedure_Specification + when N_Function_Instantiation + | N_Function_Specification + | N_Generic_Function_Renaming_Declaration + | N_Generic_Package_Renaming_Declaration + | N_Generic_Procedure_Renaming_Declaration + | N_Package_Body + | N_Package_Instantiation + | N_Package_Renaming_Declaration + | N_Package_Specification + | N_Procedure_Instantiation + | N_Procedure_Specification => declare Nam : constant Node_Id := Defining_Unit_Name (N); @@ -5272,8 +5279,9 @@ package body Sem_Util is end if; end; - when N_Block_Statement | - N_Loop_Statement => + when N_Block_Statement + | N_Loop_Statement + => return Entity (Identifier (N)); when others => @@ -5282,7 +5290,6 @@ package body Sem_Util is else raise Program_Error; end if; - end case; end Defining_Entity; @@ -5818,8 +5825,9 @@ package body Sem_Util is -- Treat the unchecked attributes as library-level - when Attribute_Unchecked_Access | - Attribute_Unrestricted_Access => + when Attribute_Unchecked_Access + | Attribute_Unrestricted_Access + => return Make_Level_Literal (Scope_Depth (Standard_Standard)); -- No other access-valued attributes @@ -7290,11 +7298,10 @@ package body Sem_Util is pragma Assert (Present (Alt)); end loop Search; - -- The above loop *must* terminate by finding a match, since - -- we know the case statement is valid, and the value of the - -- expression is known at compile time. When we fall out of - -- the loop, Alt points to the alternative that we know will - -- be selected at run time. + -- The above loop *must* terminate by finding a match, since we know the + -- case statement is valid, and the value of the expression is known at + -- compile time. When we fall out of the loop, Alt points to the + -- alternative that we know will be selected at run time. return Alt; end Find_Static_Alternative; @@ -7847,10 +7854,10 @@ package body Sem_Util is return Entity (N); else case Nkind (N) is - when N_Indexed_Component | - N_Slice | - N_Selected_Component => - + when N_Indexed_Component + | N_Selected_Component + | N_Slice + => -- If not generating code, a dereference may be left implicit. -- In thoses cases, return Empty. @@ -8933,10 +8940,10 @@ package body Sem_Util is Assn := First (Constraints (Constr)); while Present (Assn) loop case Nkind (Assn) is - when N_Subtype_Indication | - N_Range | - N_Identifier - => + when N_Identifier + | N_Range + | N_Subtype_Indication + => if Depends_On_Discriminant (Assn) then return True; end if; @@ -9518,19 +9525,21 @@ package body Sem_Util is function Has_Null_Exclusion (N : Node_Id) return Boolean is begin case Nkind (N) is - when N_Access_Definition | - N_Access_Function_Definition | - N_Access_Procedure_Definition | - N_Access_To_Object_Definition | - N_Allocator | - N_Derived_Type_Definition | - N_Function_Specification | - N_Subtype_Declaration => + when N_Access_Definition + | N_Access_Function_Definition + | N_Access_Procedure_Definition + | N_Access_To_Object_Definition + | N_Allocator + | N_Derived_Type_Definition + | N_Function_Specification + | N_Subtype_Declaration + => return Null_Exclusion_Present (N); - when N_Component_Definition | - N_Formal_Object_Declaration | - N_Object_Renaming_Declaration => + when N_Component_Definition + | N_Formal_Object_Declaration + | N_Object_Renaming_Declaration + => if Present (Subtype_Mark (N)) then return Null_Exclusion_Present (N); else pragma Assert (Present (Access_Definition (N))); @@ -9560,7 +9569,6 @@ package body Sem_Util is when others => return False; - end case; end Has_Null_Exclusion; @@ -12087,22 +12095,23 @@ package body Sem_Util is function Is_Declaration_Other_Than_Renaming (N : Node_Id) return Boolean is begin case Nkind (N) is - when N_Abstract_Subprogram_Declaration | - N_Exception_Declaration | - N_Expression_Function | - N_Full_Type_Declaration | - N_Generic_Package_Declaration | - N_Generic_Subprogram_Declaration | - N_Number_Declaration | - N_Object_Declaration | - N_Package_Declaration | - N_Private_Extension_Declaration | - N_Private_Type_Declaration | - N_Subprogram_Declaration | - N_Subtype_Declaration => + when N_Abstract_Subprogram_Declaration + | N_Exception_Declaration + | N_Expression_Function + | N_Full_Type_Declaration + | N_Generic_Package_Declaration + | N_Generic_Subprogram_Declaration + | N_Number_Declaration + | N_Object_Declaration + | N_Package_Declaration + | N_Private_Extension_Declaration + | N_Private_Type_Declaration + | N_Subprogram_Declaration + | N_Subtype_Declaration + => return True; - when others => + when others => return False; end case; end Is_Declaration_Other_Than_Renaming; @@ -13283,7 +13292,9 @@ package body Sem_Util is else case Nkind (N) is - when N_Indexed_Component | N_Slice => + when N_Indexed_Component + | N_Slice + => return Is_Object_Reference (Prefix (N)) or else Is_Access_Type (Etype (Prefix (N))); @@ -14219,16 +14230,17 @@ package body Sem_Util is function Is_Renaming_Declaration (N : Node_Id) return Boolean is begin case Nkind (N) is - when N_Exception_Renaming_Declaration | - N_Generic_Function_Renaming_Declaration | - N_Generic_Package_Renaming_Declaration | - N_Generic_Procedure_Renaming_Declaration | - N_Object_Renaming_Declaration | - N_Package_Renaming_Declaration | - N_Subprogram_Renaming_Declaration => + when N_Exception_Renaming_Declaration + | N_Generic_Function_Renaming_Declaration + | N_Generic_Package_Renaming_Declaration + | N_Generic_Procedure_Renaming_Declaration + | N_Object_Renaming_Declaration + | N_Package_Renaming_Declaration + | N_Subprogram_Renaming_Declaration + => return True; - when others => + when others => return False; end case; end Is_Renaming_Declaration; @@ -14397,23 +14409,27 @@ package body Sem_Util is pragma Assert (Nkind (Orig_N) in N_Subexpr); case Nkind (Orig_N) is - 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 + => null; - when N_Identifier | - N_Expanded_Name => + when N_Expanded_Name + | N_Identifier + => if Is_Entity_Name (Orig_N) and then Present (Entity (Orig_N)) -- needed in some cases then case Ekind (Entity (Orig_N)) is - when E_Constant | - E_Enumeration_Literal | - E_Named_Integer | - E_Named_Real => + when E_Constant + | E_Enumeration_Literal + | E_Named_Integer + | E_Named_Real + => null; + when others => if Is_Type (Entity (Orig_N)) then null; @@ -14423,22 +14439,25 @@ package body Sem_Util is end case; end if; - when N_Qualified_Expression | - N_Type_Conversion => + when N_Qualified_Expression + | N_Type_Conversion + => Is_Ok := Is_SPARK_05_Initialization_Expr (Expression (Orig_N)); when N_Unary_Op => Is_Ok := Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N)); - when N_Binary_Op | - N_Short_Circuit | - N_Membership_Test => + when N_Binary_Op + | N_Membership_Test + | N_Short_Circuit + => Is_Ok := Is_SPARK_05_Initialization_Expr (Left_Opnd (Orig_N)) and then Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N)); - when N_Aggregate | - N_Extension_Aggregate => + when N_Aggregate + | N_Extension_Aggregate + => if Nkind (Orig_N) = N_Extension_Aggregate then Is_Ok := Is_SPARK_05_Initialization_Expr (Ancestor_Part (Orig_N)); @@ -15037,7 +15056,9 @@ package body Sem_Util is else case Nkind (Orig_Node) is - when N_Indexed_Component | N_Slice => + when N_Indexed_Component + | N_Slice + => return Is_Variable_Prefix (Prefix (Orig_Node)); when N_Selected_Component => @@ -15397,9 +15418,9 @@ package body Sem_Util is -- Positional parameter for procedure or accept call - when N_Procedure_Call_Statement | - N_Accept_Statement - => + when N_Accept_Statement + | N_Procedure_Call_Statement + => declare Proc : Entity_Id; Form : Entity_Id; @@ -15487,7 +15508,6 @@ package body Sem_Util is when others => return False; - end case; end Known_To_Be_Assigned; @@ -15681,7 +15701,9 @@ package body Sem_Util is -- or slice is an lvalue, except if it is an access type, where we -- have an implicit dereference. - when N_Indexed_Component | N_Slice => + when N_Indexed_Component + | N_Slice + => if N /= Prefix (P) or else (Present (Etype (N)) and then Is_Access_Type (Etype (N))) then @@ -15704,9 +15726,9 @@ package body Sem_Util is -- In older versions of Ada function call arguments are never -- lvalues. In Ada 2012 functions can have in-out parameters. - when N_Subprogram_Call | - N_Entry_Call_Statement | - N_Accept_Statement + when N_Accept_Statement + | N_Entry_Call_Statement + | N_Subprogram_Call => if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then return False; @@ -15807,7 +15829,6 @@ package body Sem_Util is when others => return False; - end case; end May_Be_Lvalue; @@ -17746,7 +17767,6 @@ package body Sem_Util is else Return_Master_Scope_Depth_Of_Call : declare - function Innermost_Master_Scope_Depth (N : Node_Id) return Uint; -- Returns the scope depth of the given node's innermost @@ -17769,42 +17789,42 @@ package body Sem_Util is while Present (Node_Par) loop case Nkind (Node_Par) is - when N_Component_Declaration | - N_Entry_Declaration | - N_Formal_Object_Declaration | - N_Formal_Type_Declaration | - N_Full_Type_Declaration | - N_Incomplete_Type_Declaration | - N_Loop_Parameter_Specification | - N_Object_Declaration | - N_Protected_Type_Declaration | - N_Private_Extension_Declaration | - N_Private_Type_Declaration | - N_Subtype_Declaration | - N_Function_Specification | - N_Procedure_Specification | - N_Task_Type_Declaration | - N_Body_Stub | - N_Generic_Instantiation | - N_Proper_Body | - N_Implicit_Label_Declaration | - N_Package_Declaration | - N_Single_Task_Declaration | - N_Subprogram_Declaration | - N_Generic_Declaration | - N_Renaming_Declaration | - N_Block_Statement | - N_Formal_Subprogram_Declaration | - N_Abstract_Subprogram_Declaration | - N_Entry_Body | - N_Exception_Declaration | - N_Formal_Package_Declaration | - N_Number_Declaration | - N_Package_Specification | - N_Parameter_Specification | - N_Single_Protected_Declaration | - N_Subunit => - + when N_Abstract_Subprogram_Declaration + | N_Block_Statement + | N_Body_Stub + | N_Component_Declaration + | N_Entry_Body + | N_Entry_Declaration + | N_Exception_Declaration + | N_Formal_Object_Declaration + | N_Formal_Package_Declaration + | N_Formal_Subprogram_Declaration + | N_Formal_Type_Declaration + | N_Full_Type_Declaration + | N_Function_Specification + | N_Generic_Declaration + | N_Generic_Instantiation + | N_Implicit_Label_Declaration + | N_Incomplete_Type_Declaration + | N_Loop_Parameter_Specification + | N_Number_Declaration + | N_Object_Declaration + | N_Package_Declaration + | N_Package_Specification + | N_Parameter_Specification + | N_Private_Extension_Declaration + | N_Private_Type_Declaration + | N_Procedure_Specification + | N_Proper_Body + | N_Protected_Type_Declaration + | N_Renaming_Declaration + | N_Single_Protected_Declaration + | N_Single_Task_Declaration + | N_Subprogram_Declaration + | N_Subtype_Declaration + | N_Subunit + | N_Task_Type_Declaration + => return Scope_Depth (Nearest_Dynamic_Scope (Defining_Entity (Node_Par))); @@ -20382,7 +20402,8 @@ package body Sem_Util is case Size is when 8 | 16 | 32 | 64 => return Size = UI_To_Int (Alignment (Typ)) * 8; - when others => + + when others => return False; end case; end Support_Atomic_Primitives; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 18f94e50014..5cd37f0c619 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -990,7 +990,7 @@ package body Sem_Warn is -- Similarly, the generic formals of a generic subprogram are -- not accessible. - when N_Generic_Subprogram_Declaration => + when N_Generic_Subprogram_Declaration => if Is_List_Member (Prev) and then List_Containing (Prev) = Generic_Formal_Declarations (P) @@ -1014,12 +1014,13 @@ package body Sem_Warn is -- If we reach any other body, definitely not referenceable - when N_Package_Body | - N_Task_Body | - N_Entry_Body | - N_Protected_Body | - N_Block_Statement | - N_Subunit => + when N_Block_Statement + | N_Entry_Body + | N_Package_Body + | N_Protected_Body + | N_Subunit + | N_Task_Body + => return False; -- For all other cases, keep looking up tree @@ -1792,7 +1793,9 @@ package body Sem_Warn is -- For identifier or expanded name, examine the entity involved - when N_Identifier | N_Expanded_Name => + when N_Expanded_Name + | N_Identifier + => declare E : constant Entity_Id := Entity (N); @@ -2052,8 +2055,9 @@ package body Sem_Warn is -- Indexed component or slice - when N_Indexed_Component | N_Slice => - + when N_Indexed_Component + | N_Slice + => -- If prefix does not involve dereferencing an access type, then -- we know we are OK if the component type is fully initialized, -- since the component will have been set as part of the default @@ -2124,9 +2128,10 @@ package body Sem_Warn is -- For type conversions, qualifications, or expressions with actions, -- examine the expression. - when N_Type_Conversion | - N_Qualified_Expression | - N_Expression_With_Actions => + when N_Expression_With_Actions + | N_Qualified_Expression + | N_Type_Conversion + => Check_Unset_Reference (Expression (N)); -- For explicit dereference, always check prefix, which will generate @@ -2139,7 +2144,6 @@ package body Sem_Warn is when others => null; - end case; end Check_Unset_Reference; @@ -4141,11 +4145,11 @@ package body Sem_Warn is end if; end if; - when E_In_Parameter | - E_In_Out_Parameter => - - -- Do not emit message for formals of a renaming, because - -- they are never referenced explicitly. + when E_In_Out_Parameter + | E_In_Parameter + => + -- Do not emit message for formals of a renaming, because they + -- are never referenced explicitly. if Nkind (Original_Node (Unit_Declaration_Node (Scope (E)))) /= N_Subprogram_Renaming_Declaration @@ -4176,8 +4180,9 @@ package body Sem_Warn is when E_Discriminant => Error_Msg_N ("?u?discriminant & is not referenced!", E); - when E_Named_Integer | - E_Named_Real => + when E_Named_Integer + | E_Named_Real + => Error_Msg_N -- CODEFIX ("?u?named number & is not referenced!", E); diff --git a/gcc/ada/set_targ.adb b/gcc/ada/set_targ.adb index 1020d5c1240..f25c9f84f81 100755 --- a/gcc/ada/set_targ.adb +++ b/gcc/ada/set_targ.adb @@ -203,10 +203,14 @@ package body Set_Targ is begin case T is - when S_Short_Float | S_Float => + when S_Float + | S_Short_Float + => return "float"; + when S_Long_Float => return "double"; + when S_Long_Long_Float => if Long_Double_Index >= 0 and then FPT_Mode_Table (Long_Double_Index).DIGS <= Max_HW_Digs @@ -302,8 +306,8 @@ package body Set_Targ is Write_Str ("pragma Float_Representation ("); case Float_Rep is - when IEEE_Binary => Write_Str ("IEEE"); when AAMP => Write_Str ("AAMP"); + when IEEE_Binary => Write_Str ("IEEE"); end case; Write_Line (", " & T (1 .. Last) & ");"); @@ -525,10 +529,8 @@ package body Set_Targ is AddC (' '); case E.FLOAT_REP is - when IEEE_Binary => - AddC ('I'); - when AAMP => - AddC ('A'); + when AAMP => AddC ('A'); + when IEEE_Binary => AddC ('I'); end case; AddC (' '); @@ -781,8 +783,10 @@ package body Set_Targ is case Buffer (N) is when 'I' => E.FLOAT_REP := IEEE_Binary; + when 'A' => E.FLOAT_REP := AAMP; + when others => FailN ("bad float rep field for"); end case; diff --git a/gcc/ada/sinput-l.adb b/gcc/ada/sinput-l.adb index aa9acb897d2..8141262d558 100644 --- a/gcc/ada/sinput-l.adb +++ b/gcc/ada/sinput-l.adb @@ -817,8 +817,10 @@ package body Sinput.L is -- PRAGMA, WITH, USE (which can appear before a body) - when Tok_Pragma | Tok_With | Tok_Use => - + when Tok_Pragma + | Tok_Use + | Tok_With + => -- We just want to skip any of these, do it by skipping to a -- semicolon, but check for EOF, in case we have bad syntax. @@ -844,7 +846,9 @@ package body Sinput.L is -- FUNCTION or PROCEDURE - when Tok_Procedure | Tok_Function => + when Tok_Function + | Tok_Procedure + => Pcount := 0; -- Loop through tokens following PROCEDURE or FUNCTION @@ -870,7 +874,10 @@ package body Sinput.L is -- BEGIN or IS or END definitely means body is present - when Tok_Begin | Tok_Is | Tok_End => + when Tok_Begin + | Tok_End + | Tok_Is + => return True; -- Semicolon means no body present if at outside any diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb index a03949463e9..4b4775734b3 100644 --- a/gcc/ada/sinput.adb +++ b/gcc/ada/sinput.adb @@ -280,13 +280,17 @@ package body Sinput is Wide_Character_Encoding_Method := WCEM_UTF8; Upper_Half_Encoding := True; - when UTF16_LE | UTF16_BE => + when UTF16_BE + | UTF16_LE + => Set_Standard_Error; Write_Line ("UTF-16 encoding format not recognized"); Set_Standard_Output; raise Unrecoverable_Error; - when UTF32_LE | UTF32_BE => + when UTF32_BE + | UTF32_LE + => Set_Standard_Error; Write_Line ("UTF-32 encoding format not recognized"); Set_Standard_Output; diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index bf85f016516..3951b5778b8 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -3976,7 +3976,9 @@ package body Sprint is Write_Str (");"); - when E_Signed_Integer_Subtype | E_Enumeration_Subtype => + when E_Enumeration_Subtype + | E_Signed_Integer_Subtype + => Write_Str_With_Col_Check ("subtype "); Write_Id (E); Write_Str (" is "); @@ -3992,7 +3994,6 @@ package body Sprint is Write_Ekind (E); Write_Str (">;"); end case; - end Write_Implicit_Def; ------------------ @@ -4265,11 +4266,11 @@ package body Sprint is -- Signed integer types, and modular integer subtypes, -- and also enumeration subtypes. - when E_Signed_Integer_Type | - E_Signed_Integer_Subtype | - E_Modular_Integer_Subtype | - E_Enumeration_Subtype => - + when E_Enumeration_Subtype + | E_Modular_Integer_Subtype + | E_Signed_Integer_Subtype + | E_Signed_Integer_Type + => Write_Header (Ekind (Typ) = E_Signed_Integer_Type); if Ekind (Typ) = E_Signed_Integer_Type then @@ -4329,9 +4330,9 @@ package body Sprint is -- Floating point types and subtypes - when E_Floating_Point_Type | - E_Floating_Point_Subtype => - + when E_Floating_Point_Subtype + | E_Floating_Point_Type + => Write_Header (Ekind (Typ) = E_Floating_Point_Type); if Ekind (Typ) = E_Floating_Point_Type then @@ -4374,7 +4375,9 @@ package body Sprint is -- Record subtypes - when E_Record_Subtype | E_Record_Subtype_With_Private => + when E_Record_Subtype + | E_Record_Subtype_With_Private + => Write_Header (False); Write_Str ("record"); Indent_Begin; @@ -4397,8 +4400,9 @@ package body Sprint is -- Class-Wide types - when E_Class_Wide_Type | - E_Class_Wide_Subtype => + when E_Class_Wide_Subtype + | E_Class_Wide_Type + => Write_Header (Ekind (Typ) = E_Class_Wide_Type); Write_Name_With_Col_Check (Chars (Etype (Typ))); Write_Str ("'Class"); @@ -4467,7 +4471,6 @@ package body Sprint is when others => Write_Header (True); Write_Str ("???"); - end case; end if; diff --git a/gcc/ada/stylesw.adb b/gcc/ada/stylesw.adb index 8ff3ce6db54..ff8155adfc9 100644 --- a/gcc/ada/stylesw.adb +++ b/gcc/ada/stylesw.adb @@ -306,7 +306,6 @@ package body Stylesw is if On then case C is - when '+' => null; @@ -480,7 +479,6 @@ package body Stylesw is else case C is - when '+' => On := True; diff --git a/gcc/ada/switch-m.adb b/gcc/ada/switch-m.adb index fcbcafbc88c..8795703bac7 100644 --- a/gcc/ada/switch-m.adb +++ b/gcc/ada/switch-m.adb @@ -150,7 +150,6 @@ package body Switch.M is -- Processing for a switch case Switch_Starts_With_Gnat is - when False => -- All switches that don't start with -gnat stay as is, @@ -218,15 +217,15 @@ package body Switch.M is return; when True => - case C is -- One-letter switches - when 'a' | 'A' | 'b' | 'B' | 'c' | 'C' | 'E' | 'f' | - 'F' | 'g' | 'h' | 'H' | 'I' | 'L' | 'N' | 'p' | - 'P' | 'q' | 'Q' | 'r' | 's' | 'S' | 't' | 'u' | - 'U' | 'v' | 'x' | 'X' | 'Z' => + when 'a' | 'A' | 'b' | 'B' | 'c' | 'C' | 'E' | 'f' | 'F' + | 'g' | 'h' | 'H' | 'I' | 'L' | 'N' | 'p' | 'P' | 'q' + | 'Q' | 'r' | 's' | 'S' | 't' | 'u' | 'U' | 'v' | 'x' + | 'X' | 'Z' + => Storing (First_Stored) := C; Add_Switch_Component (Storing (Storing'First .. First_Stored)); @@ -291,7 +290,6 @@ package body Switch.M is else case Switch_Chars (Ptr) is - when 'A' => Ptr := Ptr + 1; Add_Switch_Component ("-gnateA"); @@ -687,9 +685,7 @@ package body Switch.M is when others => Last := 0; return; - end case; - end case; end loop; end Normalize_Compiler_Switches; @@ -793,17 +789,10 @@ package body Switch.M is Verbose_Mode := True; case Switch_Chars (Ptr) is - when 'l' => - Verbosity_Level := Opt.Low; - - when 'm' => - Verbosity_Level := Opt.Medium; - - when 'h' => - Verbosity_Level := Opt.High; - - when others => - Success := False; + when 'l' => Verbosity_Level := Opt.Low; + when 'm' => Verbosity_Level := Opt.Medium; + when 'h' => Verbosity_Level := Opt.High; + when others => Success := False; end case; elsif C = 'd' then @@ -916,9 +905,7 @@ package body Switch.M is else Check_Switch : begin - case C is - when 'a' => Check_Readonly_Files := True; @@ -1058,7 +1045,6 @@ package body Switch.M is else Success := False; end if; - end case; end Check_Switch; end if; diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index 27662dd3fca..7c1f1b7d93e 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -603,13 +603,13 @@ package body Treepr is begin case M is - when Default_Mechanism => + when Default_Mechanism => Write_Str ("Default"); - when By_Copy => + when By_Copy => Write_Str ("By_Copy"); - when By_Reference => + when By_Reference => Write_Str ("By_Reference"); when 1 .. Mechanism_Type'Last => @@ -1200,8 +1200,8 @@ package body Treepr is F := Pchars (P); P := P + 1; - -- Check for case of False flag, which we never print, or - -- an Empty field, which is also never printed + -- Check for case of False flag, which we never print, or an Empty + -- field, which is also never printed. case F is when F_Field1 => @@ -1268,24 +1268,24 @@ package body Treepr is Print_Field (Field5 (N), Fmt); end if; - when F_Flag1 => Print_Flag (Flag1 (N)); - when F_Flag2 => Print_Flag (Flag2 (N)); - when F_Flag3 => Print_Flag (Flag3 (N)); - when F_Flag4 => Print_Flag (Flag4 (N)); - when F_Flag5 => Print_Flag (Flag5 (N)); - when F_Flag6 => Print_Flag (Flag6 (N)); - when F_Flag7 => Print_Flag (Flag7 (N)); - when F_Flag8 => Print_Flag (Flag8 (N)); - when F_Flag9 => Print_Flag (Flag9 (N)); - when F_Flag10 => Print_Flag (Flag10 (N)); - when F_Flag11 => Print_Flag (Flag11 (N)); - when F_Flag12 => Print_Flag (Flag12 (N)); - when F_Flag13 => Print_Flag (Flag13 (N)); - when F_Flag14 => Print_Flag (Flag14 (N)); - when F_Flag15 => Print_Flag (Flag15 (N)); - when F_Flag16 => Print_Flag (Flag16 (N)); - when F_Flag17 => Print_Flag (Flag17 (N)); - when F_Flag18 => Print_Flag (Flag18 (N)); + when F_Flag1 => Print_Flag (Flag1 (N)); + when F_Flag2 => Print_Flag (Flag2 (N)); + when F_Flag3 => Print_Flag (Flag3 (N)); + when F_Flag4 => Print_Flag (Flag4 (N)); + when F_Flag5 => Print_Flag (Flag5 (N)); + when F_Flag6 => Print_Flag (Flag6 (N)); + when F_Flag7 => Print_Flag (Flag7 (N)); + when F_Flag8 => Print_Flag (Flag8 (N)); + when F_Flag9 => Print_Flag (Flag9 (N)); + when F_Flag10 => Print_Flag (Flag10 (N)); + when F_Flag11 => Print_Flag (Flag11 (N)); + when F_Flag12 => Print_Flag (Flag12 (N)); + when F_Flag13 => Print_Flag (Flag13 (N)); + when F_Flag14 => Print_Flag (Flag14 (N)); + when F_Flag15 => Print_Flag (Flag15 (N)); + when F_Flag16 => Print_Flag (Flag16 (N)); + when F_Flag17 => Print_Flag (Flag17 (N)); + when F_Flag18 => Print_Flag (Flag18 (N)); end case; Print_Eol; @@ -1637,10 +1637,13 @@ package body Treepr is case N is when List_Low_Bound .. List_High_Bound - 1 => Print_List_Subtree (List_Id (N)); + when Node_Range => Print_Node_Subtree (Node_Id (N)); + when Elist_Range => Print_Elist_Subtree (Elist_Id (N)); + when others => pp (N); end case; @@ -1684,7 +1687,6 @@ package body Treepr is Hash_Slot := H; Hash_Table (H).Id := Id; return 0; - end Serial_Number; ----------------------- diff --git a/gcc/ada/uname.adb b/gcc/ada/uname.adb index 84518017698..c879cbbdee2 100644 --- a/gcc/ada/uname.adb +++ b/gcc/ada/uname.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- -- @@ -234,85 +234,89 @@ package body Uname is else case Kind is - - when N_Identifier | - N_Defining_Identifier | - N_Defining_Operator_Symbol => - + when N_Defining_Identifier + | N_Defining_Operator_Symbol + | N_Identifier + => -- Note: it is of course an error to have a defining -- operator symbol at this point, but this is not where -- the error is signalled, so we handle it nicely here. Add_Name (Chars (Node)); - when N_Defining_Program_Unit_Name => + when N_Defining_Program_Unit_Name => Add_Node_Name (Name (Node)); Add_Char ('.'); Add_Node_Name (Defining_Identifier (Node)); - when N_Selected_Component | - N_Expanded_Name => + when N_Expanded_Name + | N_Selected_Component + => Add_Node_Name (Prefix (Node)); Add_Char ('.'); Add_Node_Name (Selector_Name (Node)); - when N_Subprogram_Specification | - N_Package_Specification => + when N_Package_Specification + | N_Subprogram_Specification + => Add_Node_Name (Defining_Unit_Name (Node)); - when N_Subprogram_Body | - N_Subprogram_Declaration | - N_Package_Declaration | - N_Generic_Declaration => + when N_Generic_Declaration + | N_Package_Declaration + | N_Subprogram_Body + | N_Subprogram_Declaration + => Add_Node_Name (Specification (Node)); - when N_Generic_Instantiation => + when N_Generic_Instantiation => Add_Node_Name (Defining_Unit_Name (Node)); - when N_Package_Body => + when N_Package_Body => Add_Node_Name (Defining_Unit_Name (Node)); - when N_Task_Body | - N_Protected_Body => + when N_Protected_Body + | N_Task_Body + => Add_Node_Name (Defining_Identifier (Node)); - when N_Package_Renaming_Declaration => + when N_Package_Renaming_Declaration => Add_Node_Name (Defining_Unit_Name (Node)); when N_Subprogram_Renaming_Declaration => Add_Node_Name (Specification (Node)); - when N_Generic_Renaming_Declaration => + when N_Generic_Renaming_Declaration => Add_Node_Name (Defining_Unit_Name (Node)); - when N_Subprogram_Body_Stub => + when N_Subprogram_Body_Stub => Add_Node_Name (Get_Parent (Node)); Add_Char ('.'); Add_Node_Name (Specification (Node)); - when N_Compilation_Unit => + when N_Compilation_Unit => Add_Node_Name (Unit (Node)); - when N_Package_Body_Stub => + when N_Package_Body_Stub => Add_Node_Name (Get_Parent (Node)); Add_Char ('.'); Add_Node_Name (Defining_Identifier (Node)); - when N_Task_Body_Stub | - N_Protected_Body_Stub => + when N_Protected_Body_Stub + | N_Task_Body_Stub + => Add_Node_Name (Get_Parent (Node)); Add_Char ('.'); Add_Node_Name (Defining_Identifier (Node)); - when N_Subunit => + when N_Subunit => Add_Node_Name (Name (Node)); Add_Char ('.'); Add_Node_Name (Proper_Body (Node)); - when N_With_Clause => + when N_With_Clause => Add_Node_Name (Name (Node)); - when N_Pragma => + when N_Pragma => Add_Node_Name (Expression (First (Pragma_Argument_Associations (Node)))); @@ -321,15 +325,15 @@ package body Uname is -- with these error situations here, and produce a reasonable -- unit name using the defining identifier. - when N_Task_Type_Declaration | - N_Single_Task_Declaration | - N_Protected_Type_Declaration | - N_Single_Protected_Declaration => + when N_Protected_Type_Declaration + | N_Single_Protected_Declaration + | N_Single_Task_Declaration + | N_Task_Type_Declaration + => Add_Node_Name (Defining_Identifier (Node)); when others => raise Program_Error; - end case; end if; end Add_Node_Name; @@ -378,31 +382,31 @@ package body Uname is Add_Char ('%'); case Nkind (Node) is - when N_Generic_Declaration | - N_Subprogram_Declaration | - N_Package_Declaration | - N_With_Clause | - N_Pragma | - N_Generic_Instantiation | - N_Package_Renaming_Declaration | - N_Subprogram_Renaming_Declaration | - N_Generic_Renaming_Declaration | - N_Single_Task_Declaration | - N_Single_Protected_Declaration | - N_Task_Type_Declaration | - N_Protected_Type_Declaration => - + when N_Generic_Declaration + | N_Generic_Instantiation + | N_Generic_Renaming_Declaration + | N_Package_Declaration + | N_Package_Renaming_Declaration + | N_Pragma + | N_Protected_Type_Declaration + | N_Single_Protected_Declaration + | N_Single_Task_Declaration + | N_Subprogram_Declaration + | N_Subprogram_Renaming_Declaration + | N_Task_Type_Declaration + | N_With_Clause + => Add_Char ('s'); - when N_Subprogram_Body | - N_Package_Body | - N_Subunit | - N_Body_Stub | - N_Task_Body | - N_Protected_Body | - N_Identifier | - N_Selected_Component => - + when N_Body_Stub + | N_Identifier + | N_Package_Body + | N_Protected_Body + | N_Selected_Component + | N_Subprogram_Body + | N_Subunit + | N_Task_Body + => Add_Char ('b'); when others => diff --git a/gcc/ada/validsw.adb b/gcc/ada/validsw.adb index 517180ad936..18adda31187 100644 --- a/gcc/ada/validsw.adb +++ b/gcc/ada/validsw.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2013, 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- -- @@ -132,7 +132,6 @@ package body Validsw is Validity_Checks_On := True; case C is - when 'c' => Validity_Check_Copies := True; @@ -237,7 +236,6 @@ package body Validsw is Err_Col := J - 1; return; end if; - end case; end loop; diff --git a/gcc/ada/widechar.adb b/gcc/ada/widechar.adb index d0c8f249280..8dd162cf414 100644 --- a/gcc/ada/widechar.adb +++ b/gcc/ada/widechar.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. -- -- -- -- 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- -- @@ -74,10 +74,11 @@ package body Widechar is -- All other encoding methods use the upper bit set in the first -- character to uniquely represent a wide character. - when WCEM_Upper | - WCEM_Shift_JIS | - WCEM_EUC | - WCEM_UTF8 => + when WCEM_EUC + | WCEM_Shift_JIS + | WCEM_Upper + | WCEM_UTF8 + => return S (P) >= Character'Val (16#80#); end case; end Is_Start_Of_Wide_Char; diff --git a/gcc/ada/xoscons.adb b/gcc/ada/xoscons.adb index 3d5bfab4153..8eecb298f36 100644 --- a/gcc/ada/xoscons.adb +++ b/gcc/ada/xoscons.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2008-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-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- -- @@ -354,7 +354,12 @@ procedure XOSCons is Integer (Parse_Int (Line (Index1 .. Index2 - 1), CNU).Abs_Value); case Info.Kind is - when CND | CNU | CNS | C | SUB => + when C + | CND + | CNS + | CNU + | SUB + => Index1 := Index2 + 1; Find_Colon (Index2); diff --git a/gcc/ada/xr_tabls.adb b/gcc/ada/xr_tabls.adb index 0b97c121da2..8a6411c75e3 100644 --- a/gcc/ada/xr_tabls.adb +++ b/gcc/ada/xr_tabls.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- 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- -- @@ -401,8 +401,8 @@ package body Xr_Tabls is begin case Ref_Type is - when 'b' | 'c' | 'H' | 'm' | 'o' | 'r' | 'R' | - 's' | 'i' | ' ' | 'x' => + when ' ' | 'b' | 'c' | 'H' | 'i' | 'm' | 'o' | 'r' | 'R' | 's' | 'x' + => null; when 'l' | 'w' => @@ -430,10 +430,10 @@ package body Xr_Tabls is Decl_Type => ' ', Is_Parameter => True); - when 'e' | 'E' | 'z' | 't' | 'p' | 'P' | 'k' | 'd' => + when 'd' | 'e' | 'E' | 'k' | 'p' | 'P' | 't' | 'z' => return; - when others => + when others => Ada.Text_IO.Put_Line ("Unknown reference type: " & Ref_Type); return; end case; @@ -455,7 +455,7 @@ package body Xr_Tabls is New_Ref.Next := Declaration.Body_Ref; Declaration.Body_Ref := New_Ref; - when 'r' | 'R' | 's' | 'H' | 'i' | 'l' | 'o' | ' ' | 'x' | 'w' => + when ' ' | 'H' | 'i' | 'l' | 'o' | 'r' | 'R' | 's' | 'w' | 'x' => New_Ref.Next := Declaration.Ref_Ref; Declaration.Ref_Ref := New_Ref; |