+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.
-- 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- --
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),
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),
-- --
-- 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- --
Target := Source;
elsif Slength > Tlength then
-
case Drop is
when Left =>
Target := Source (Slast - Tlength + 1 .. Slast);
when Center =>
raise Length_Error;
end case;
-
end case;
-- Source'Length < Target'Length
-- --
-- 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- --
Target := Source;
elsif Slength > Tlength then
-
case Drop is
when Left =>
Target := Source (Slast - Tlength + 1 .. Slast);
when Center =>
raise Length_Error;
end case;
-
end case;
-- Source'Length < Target'Length
-- --
-- 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- --
Target := Source;
elsif Slength > Tlength then
-
case Drop is
when Left =>
Target := Source (Slast - Tlength + 1 .. Slast);
-- --
-- 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- --
raise Ada.Strings.Length_Error;
end case;
end if;
-
end Super_Append;
-- Case of Wide_Wide_String and Super_String
-- --
-- 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- --
loop
case Picture (Picture_Index) is
-
when '(' =>
Int_IO.Get
(Picture (Picture_Index + 1 .. Picture'Last), Count, Last);
Result (Result_Index) := Picture (Picture_Index);
Picture_Index := Picture_Index + 1;
Result_Index := Result_Index + 1;
-
end case;
exit when Picture_Index > Picture'Last;
exit when Answer (Last) = '9';
case Answer (Last) is
-
when '_' =>
Answer (Last) := Separator_Character;
when others =>
null;
-
end case;
exit when Last = Answer'Last;
end if;
case Answer (J) is
-
when '_' =>
Answer (J) := Separator_Character;
when others =>
null;
-
end case;
end loop;
for J in reverse Pic.Start_Float .. Position loop
case Answer (J) is
-
when '*' =>
Answer (J) := Fill_Character;
end if;
when '_' =>
-
case Pic.Floater is
-
when '*' =>
Answer (J) := Fill_Character;
when others =>
null;
-
end case;
when others =>
null;
-
end case;
end loop;
when others =>
raise Picture_Error;
-
end case;
else -- positive
case Answer (Sign_Position) is
-
when '-' =>
Answer (Sign_Position) := ' ';
when others =>
raise Picture_Error;
-
end case;
end if;
end if;
elsif Answer (J) = '_' then
Answer (J) := Separator_Character;
-
end if;
Last := J + 1;
Currency_Pos := Currency_Pos + 1;
case Pic.Floater is
-
when '*' =>
Answer (J) := Fill_Character;
when others =>
null;
-
end case;
when others =>
exit;
-
end case;
end loop;
begin
for J in Str'Range loop
case Str (J) is
-
when ' ' =>
null; -- ignore
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
end if;
case Look is
-
when '-' =>
Pic.Max_Trailing_Digits :=
Pic.Max_Trailing_Digits + 1;
when others =>
return;
-
end case;
end loop;
end if;
case Look is
-
when '+' =>
Pic.Max_Trailing_Digits :=
Pic.Max_Trailing_Digits + 1;
when others =>
return;
-
end case;
end loop;
when others =>
return;
-
end case;
end loop;
end Floating_Plus;
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;
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
when others =>
return;
-
end case;
end loop;
end Leading_Dollar;
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Inserts := True;
Debug_Start ("Number");
loop
-
case Look is
when '_' | '0' | '/' =>
Skip;
when others =>
return;
-
end case;
if At_End then
while not At_End loop
case Look is
-
when '_' | '0' | '/' =>
Skip;
end if;
case Look is
-
- when '_' | '0' | '/' => Skip;
+ when '_' | '0' | '/' =>
+ Skip;
when 'B' | 'b' =>
Pic.Picture.Expanded (Index) := 'b';
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
when others =>
return;
-
end case;
end loop;
when others =>
Number_Fraction;
return;
-
end case;
end loop;
end Number_Fraction_Or_Pound;
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
when others =>
Number_Fraction;
return;
-
end case;
end loop;
end Number_Fraction_Or_Star_Fill;
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
end if;
case Look is
-
when '+' | '-' =>
Pic.Sign_Position := Index;
Skip;
when others =>
return;
-
end case;
end Optional_RHS_Sign;
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
when others =>
return;
-
end case;
end loop;
end Picture;
loop
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
when others =>
raise Picture_Error;
-
end case;
end loop;
end Picture_Bracket;
loop
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
when others =>
return;
-
end case;
end loop;
end Picture_Minus;
loop
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
when others =>
return;
-
end case;
end loop;
end Picture_Plus;
end loop;
case Look is
-
when '$' | '#' =>
Picture;
Optional_RHS_Sign;
when others =>
raise Picture_Error;
-
end case;
-- Blank when zero either if the PIC does not contain a '9' or if
if not At_End then
Set_State (Reject);
end if;
-
end Picture_String;
---------------
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
Set_State (Okay);
return;
- when others => raise Picture_Error;
+ when others =>
+ raise Picture_Error;
end case;
end loop;
end Star_Suppression;
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;
-- --
-- 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- --
loop
case Picture (Picture_Index) is
-
when '(' =>
-- We now need to scan out the count after a left paren. In
Result (Result_Index) := Picture (Picture_Index);
Picture_Index := Picture_Index + 1;
Result_Index := Result_Index + 1;
-
end case;
exit when Picture_Index > Picture'Last;
exit when Answer (Last) = '9';
case Answer (Last) is
-
when '_' =>
Answer (Last) := Separator_Character;
when others =>
null;
-
end case;
exit when Last = Answer'Last;
end if;
case Answer (J) is
-
when '_' =>
Answer (J) := Separator_Character;
when others =>
null;
-
end case;
end loop;
for J in reverse Pic.Start_Float .. Position loop
case Answer (J) is
-
when '*' =>
Answer (J) := Fill_Character;
end if;
when '_' =>
-
case Pic.Floater is
-
when '*' =>
Answer (J) := Fill_Character;
when others =>
null;
-
end case;
when others =>
null;
-
end case;
end loop;
when others =>
raise Picture_Error;
-
end case;
else -- positive
case Answer (Sign_Position) is
-
when '-' =>
Answer (Sign_Position) := ' ';
when others =>
raise Picture_Error;
-
end case;
end if;
end if;
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));
end if;
when '_' =>
-
case Pic.Floater is
when '*' =>
when others =>
null;
-
end case;
when others =>
exit;
-
end case;
end loop;
begin
for J in Str'Range loop
case Str (J) is
-
when ' ' =>
null; -- ignore
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
return;
when others =>
- return;
+ return;
end case;
end loop;
end Floating_Bracket;
end if;
case Look is
-
when '-' =>
Pic.Max_Trailing_Digits :=
Pic.Max_Trailing_Digits + 1;
when others =>
return;
-
end case;
end loop;
end if;
case Look is
-
when '+' =>
Pic.Max_Trailing_Digits :=
Pic.Max_Trailing_Digits + 1;
when others =>
return;
-
end case;
end loop;
when others =>
return;
-
end case;
end loop;
end Floating_Plus;
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;
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
when others =>
return;
-
end case;
end loop;
end Leading_Dollar;
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Inserts := True;
procedure Number is
begin
loop
-
case Look is
when '_' | '0' | '/' =>
Skip;
when others =>
return;
-
end case;
if At_End then
begin
while not At_End loop
case Look is
-
when '_' | '0' | '/' =>
Skip;
end if;
case Look is
-
- when '_' | '0' | '/' => Skip;
+ when '_' | '0' | '/' =>
+ Skip;
when 'B' | 'b' =>
Pic.Picture.Expanded (Index) := 'b';
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
when others =>
return;
-
end case;
end loop;
when others =>
Number_Fraction;
return;
-
end case;
end loop;
end Number_Fraction_Or_Pound;
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
when others =>
Number_Fraction;
return;
-
end case;
end loop;
end Number_Fraction_Or_Star_Fill;
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
end if;
case Look is
-
when '+' | '-' =>
Pic.Sign_Position := Index;
Skip;
when others =>
return;
-
end case;
end Optional_RHS_Sign;
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
when others =>
return;
-
end case;
end loop;
end Picture;
loop
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
when others =>
raise Picture_Error;
-
end case;
end loop;
end Picture_Bracket;
loop
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
when others =>
return;
-
end case;
end loop;
end Picture_Minus;
loop
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
when others =>
return;
-
end case;
end loop;
end Picture_Plus;
end loop;
case Look is
-
when '$' | '#' =>
Picture;
Optional_RHS_Sign;
when others =>
raise Picture_Error;
-
end case;
-- Blank when zero either if the PIC does not contain a '9' or if
if not At_End then
Set_State (Reject);
end if;
-
end Picture_String;
---------------
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
Set_State (Okay);
return;
- when others => raise Picture_Error;
+ when others =>
+ raise Picture_Error;
end case;
end loop;
end Star_Suppression;
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;
-- To deal with special cases like null strings
raise Picture_Error;
-
end Precalculate;
----------------
-- --
-- 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- --
loop
case Picture (Picture_Index) is
-
when '(' =>
-- We now need to scan out the count after a left paren. In
Result (Result_Index) := Picture (Picture_Index);
Picture_Index := Picture_Index + 1;
Result_Index := Result_Index + 1;
-
end case;
exit when Picture_Index > Picture'Last;
exit when Answer (Last) = '9';
case Answer (Last) is
-
when '_' =>
Answer (Last) := Separator_Character;
when others =>
null;
-
end case;
exit when Last = Answer'Last;
end if;
case Answer (J) is
-
when '_' =>
Answer (J) := Separator_Character;
when others =>
null;
-
end case;
end loop;
for J in reverse Pic.Start_Float .. Position loop
case Answer (J) is
-
when '*' =>
Answer (J) := Fill_Character;
end if;
when '_' =>
-
case Pic.Floater is
-
when '*' =>
Answer (J) := Fill_Character;
when others =>
null;
-
end case;
when others =>
null;
-
end case;
end loop;
when others =>
raise Picture_Error;
-
end case;
else -- positive
case Answer (Sign_Position) is
-
when '-' =>
Answer (Sign_Position) := ' ';
when others =>
raise Picture_Error;
-
end case;
end if;
end if;
-- 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));
elsif Answer (J) = '_' then
Answer (J) := Separator_Character;
-
end if;
Last := J + 1;
elsif Answer (J) = 'b' then
Answer (J) := ' ';
-
end if;
end loop;
end if;
when '_' =>
-
case Pic.Floater is
-
when '*' =>
Answer (J) := Fill_Character;
when others =>
null;
-
end case;
when others =>
exit;
-
end case;
end loop;
-- 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;
begin
for J in Str'Range loop
case Str (J) is
-
when ' ' =>
null; -- ignore
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
return;
when others =>
- return;
+ return;
end case;
end loop;
end Floating_Bracket;
end if;
case Look is
-
when '-' =>
Pic.Max_Trailing_Digits :=
Pic.Max_Trailing_Digits + 1;
when others =>
return;
-
end case;
end loop;
end if;
case Look is
-
when '+' =>
Pic.Max_Trailing_Digits :=
Pic.Max_Trailing_Digits + 1;
when others =>
return;
-
end case;
end loop;
when others =>
return;
-
end case;
end loop;
end Floating_Plus;
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;
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
when others =>
return;
-
end case;
end loop;
end Leading_Dollar;
-- floating unless there is only one '#'.
procedure Leading_Pound is
-
Inserts : Boolean := False;
-- Set to True if a '_', '0', '/', 'B', or 'b' is encountered
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Inserts := True;
procedure Number is
begin
loop
-
case Look is
when '_' | '0' | '/' =>
Skip;
begin
while not At_End loop
case Look is
-
when '_' | '0' | '/' =>
Skip;
end if;
case Look is
-
- when '_' | '0' | '/' => Skip;
+ when '_' | '0' | '/' =>
+ Skip;
when 'B' | 'b' =>
Pic.Picture.Expanded (Index) := 'b';
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
when others =>
return;
-
end case;
end loop;
when others =>
Number_Fraction;
return;
-
end case;
end loop;
end Number_Fraction_Or_Pound;
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
when others =>
Number_Fraction;
return;
-
end case;
end loop;
end Number_Fraction_Or_Star_Fill;
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
end if;
case Look is
-
when '+' | '-' =>
Pic.Sign_Position := Index;
Skip;
when others =>
return;
-
end case;
end Optional_RHS_Sign;
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
when others =>
return;
-
end case;
end loop;
end Picture;
loop
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
when others =>
raise Picture_Error;
-
end case;
end loop;
end Picture_Bracket;
loop
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
when others =>
return;
-
end case;
end loop;
end Picture_Minus;
loop
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
when others =>
return;
-
end case;
end loop;
end Picture_Plus;
end loop;
case Look is
-
when '$' | '#' =>
Picture;
Optional_RHS_Sign;
when others =>
raise Picture_Error;
-
end case;
-- Blank when zero either if the PIC does not contain a '9' or if
if not At_End then
Set_State (Reject);
end if;
-
end Picture_String;
---------------
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
Set_State (Okay);
return;
- when others => raise Picture_Error;
+ when others =>
+ raise Picture_Error;
end case;
end loop;
end Star_Suppression;
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;
begin
loop
case Nextc is
- when '[' =>
+ when '[' =>
Nested_Brackets := Nested_Brackets + 1;
when ']' =>
Nested_Brackets := Nested_Brackets - 1;
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;
----------------------------------
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
---------------
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
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 =>
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;
-- 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);
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 =>
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 =>
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 =>
end if;
case Nkind (Spec) is
-
when N_Function_Specification =>
return
Make_Function_Specification (Loc,
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 =>
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;
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;
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);
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;
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;
Write_Eol;
case Ekind (Id) is
-
when Discrete_Kind =>
Write_Str ("Bounds: Id = ");
Write_Eol;
end if;
- when others => null;
+ when others =>
+ null;
end case;
end Write_Entity_Info;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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));
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;
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
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;
-- 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
-- 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;
-- 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 --
-- 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));
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))))));
end if;
Analyze_And_Resolve (N, Standard_Boolean);
- end Callable;
------------
-- Caller --
Call :=
Make_Function_Call (Loc,
- Name => Name,
+ Name => Name,
Parameter_Associations => New_List (
New_Occurrence_Of
(Find_Protection_Object (Current_Scope), Loc),
Call :=
Make_Function_Call (Loc,
- Name => Name,
+ Name => Name,
Parameter_Associations => New_List (
New_Occurrence_Of
(Find_Protection_Object (Current_Scope), Loc)));
-- 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.
-- 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 --
-- 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),
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 --
-- 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 --
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,
----------------------
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:
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);
-- 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),
Expressions => New_List (Relocate_Node (Pref))));
Analyze_And_Resolve (N, Standard_String);
- end Img;
-----------
-- Input --
-- 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),
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 --
-- (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 --
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)))
-- 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
-- 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
-- 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
-- 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.
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)));
else
Apply_Universal_Integer_Attribute_Checks (N);
end if;
- end Range_Length;
----------
-- Read --
-- 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 --
Etyp : constant Entity_Id := Base_Type (Ptyp);
begin
-
-- For enumeration types with non-standard representations, we
-- expand typ'Succ (x) into
-- 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));
-- 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))));
-- 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,
Intval => Int (Wide_Character_Encoding_Method)))))));
Analyze_And_Resolve (N, Typ);
- end Wide_Value;
---------------------
-- Wide_Wide_Value --
-- 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,
Expressions => New_List (
Make_Function_Call (Loc,
- Name =>
+ Name =>
New_Occurrence_Of
(RTE (RE_Wide_Wide_String_To_String), Loc),
Intval => Int (Wide_Character_Encoding_Method)))))));
Analyze_And_Resolve (N, Typ);
- end Wide_Wide_Value;
---------------------
-- Wide_Wide_Width --
-- 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;
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
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;
-- 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
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
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)));
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));
when others =>
null;
-
end case;
end Expand_N_Attribute_Definition_Clause;
-- Remaining processing depends on type
case Ekind (Subtype_Mark_Id) is
-
when Array_Kind =>
Constrain_Array (S, Check_List);
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;
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
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
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 =>
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;
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;
else
case Nkind (Prev_Orig) is
-
when N_Attribute_Reference =>
case Get_Attribute_Id (Attribute_Name (Prev_Orig)) 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)),
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);
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 =>
-- 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
-- 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 =>
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));
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.
null;
when others =>
-
declare
Level : constant Node_Id :=
Make_Integer_Literal (Loc,
Set_Etype (Level, Standard_Natural);
Check_Against_Result_Level (Level);
end;
-
end case;
end;
end if;
-- 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,
-- 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
-- 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
-- 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
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 =>
-- 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,
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,
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.
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;
when others =>
raise Program_Error;
-
end case;
Next (Op_Body);
when others =>
raise Program_Error;
-
end case;
end loop;
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))))
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
when others =>
return False;
-
end case;
end Trivial_Accept_OK;
Ren := Nam;
loop
case Nkind (Ren) is
-
when N_Identifier =>
exit;
(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 =>
-- --
-- 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- --
-- 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
when others =>
null;
end case;
+
Next (Decl);
end loop;
end Build_Package_Stubs;
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;
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 =>
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 =>
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);
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;
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);
-- --
-- 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- --
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
when others => null;
end case;
-
end Expand_N_Pragma;
-------------------------------
-- 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 =>
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,
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 =>
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;
-- 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
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
-- 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
if Is_Empty_List (Loop_Actions (P)) then
Set_Loop_Actions (P, Ins_Actions);
Analyze_List (Ins_Actions);
-
else
declare
Decl : Node_Id;
-- 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
-- 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
else
return False;
end if;
-
end case;
end Possible_Bit_Aligned_Component;
-- 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)
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)
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)));
-- 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
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
Requires_Cleanup_Actions
(Private_Declarations (N), At_Lib_Level, True);
- when others =>
+ when others =>
return False;
end case;
end Requires_Cleanup_Actions;
-- 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);
-- 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
-- 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
-- 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.
-- 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.
-- 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.
-- 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
when others =>
null;
-
end case;
exception
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;
return OK;
end if;
- when others => return OK;
+ when others =>
+ return OK;
end case;
end Process;
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))
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
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;
-- 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
-- --
-- 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- --
exit when K > Count_Sep;
case Mode is
-
when Single =>
-- In this mode just set start to character next to the
exit when K > Count_Sep
or else S.D.Indexes (K) > S.D.Indexes (K - 1) + 1;
end loop;
-
end case;
end loop;
-- --
-- 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- --
Split_Line (Session);
case Callbacks is
-
when None =>
exit;
when Pass_Through =>
Filter_Active := Apply_Filters (Session);
exit;
-
end case;
end loop;
end Get_Line;
-- --
-- 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- --
when others =>
raise Picture_Error with
"unknown format character in picture string";
-
end case;
-- Skip past % and format character
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;
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;
Config.Switches (Index).String_Output.all :=
new String'(Parameter);
return;
-
end case;
end if;
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;
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;
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;
when others =>
Do_Report (Report);
end case;
-
end Dump;
-----------------
Size : Positive;
Report : Report_Type := All_Reports)
is
-
procedure Internal is new Dump
(Put_Line => Stdout_Put_Line,
Put => Stdout_Put);
-- --
-- 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- --
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;
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;
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;
-- If there is no limit to the buffer size
if Descriptors (D).Buffer_Size = 0 then
-
declare
Tmp : String_Access := Descriptors (D).Buffer;
-- 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.
-- --
-- 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- --
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;
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);
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';
null;
end case;
- when Ada_Style =>
+ when Ada_Style =>
case F.Kind is
when Unsigned_Octal =>
if F.Left_Justify then
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
-- --
-- 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- --
Offset_Buf (4 .. Last - 1);
Line_Buf (AIL - 1 .. AIL) := ": ";
end;
+
when None =>
null;
end case;
-- --
-- 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- --
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;
case Opt is
when CPU_Time =>
Put (File, Type_Img (256));
+
when Memory_Space =>
Put (File, "Natural");
end case;
case Opt is
when CPU_Time =>
Put (File, "C");
+
when Memory_Space =>
Put (File, "Character'Pos");
end case;
when Graph_Table =>
return Get_Graph (J);
-
end case;
end Value;
-- --
-- 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- --
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;
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.
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 :=
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 +
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;
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
Len := VT'Size / 8;
Add := VT'Address;
end if;
-
end case;
if Option.Name in Specific_Option_Name then
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);
-- --
-- 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- --
-- 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;
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 =>
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 =>
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;
begin
case E.Pcode is
-
when PC_Cancel =>
Append (Result, "Cancel");
-- 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;
when others =>
return new PE'(PC_String, 1, EOP, new String'(Str));
-
end case;
end S_To_PE;
-- Arb (extension)
- when PC_Arb_Y =>
+ when PC_Arb_Y =>
if Cursor < Length then
Cursor := Cursor + 1;
Push (Node);
Pop_Region;
Assign_OnM := True;
goto Succeed;
-
end case;
-- We are NOT allowed to fall though this case statement, since every
-- 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;
Pop_Region;
Assign_OnM := True;
goto Succeed;
-
end case;
-- We are NOT allowed to fall though this case statement, since every
-- --
-- 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- --
when others =>
raise Program_Error;
-
end case;
-- Statement entry
-- Loop through cross-references for this entity
loop
-
declare
Line : Nat;
Col : Nat;
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 =>
when others =>
raise Program_Error;
-
end case;
end Restriction_Could_Be_Set;
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;
-- --
-- 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- --
loop
case Getopt ("g h v q k a? b: d: e: l: n m I:") is
-
when ASCII.NUL =>
exit;
end if;
when 'k' =>
-
MDLL.Kill_Suffix := True;
when 'a' =>
-
if Parameter = "" then
-- Default address for a relocatable dynamic library.
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' =>
Build_Mode := Dynamic_Lib;
when 'm' =>
-
Gen_Map_File := True;
when 'n' =>
-
Build_Import := False;
when 'l' =>
loop
case Getopt ("*") is
-
when ASCII.NUL =>
exit;
when others =>
Bopts (B) := new String'(Full_Switch);
B := B + 1;
-
end case;
end loop;
-- --
-- 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- --
Switch := GNAT.Command_Line.Getopt ("D: a b c C r s T u v");
case Switch is
-
when ASCII.NUL =>
exit;
-- --
-- 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- --
Val := abs Val;
Convert (1, Length);
Embed_Sign (Length);
-
end case;
return Result;
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
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
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
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 =>
end if;
end;
- when E_Loop_Parameter | E_In_Parameter =>
+ when E_In_Parameter
+ | E_Loop_Parameter
+ =>
Result := True;
when others =>
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
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;
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 =>
when others =>
null;
end case;
+
return OK;
end Process;
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 =>
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
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 =>
-- --
-- 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- --
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;
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;
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;
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;
-- --
-- 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- --
-- 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,
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;
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;
-- --
-- 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- --
-- 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;
Error_Msg_BC ("expecting generic type definition here");
Resync_Past_Semicolon;
return Error;
-
end case;
end P_Formal_Type_Definition;
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;
-- 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;
Error_Msg_AP ("type definition expected");
raise Error_Resync;
end if;
-
end case;
end loop;
end if;
case Token is
-
when Tok_Function =>
Check_Bad_Layout;
Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
-- 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.
-- 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
-- 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;
Error_Msg_AP ("missing operand");
raise Error_Resync;
end if;
-
end case;
end loop;
end P_Primary;
-- --
-- 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- --
-- 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;
-- 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;
-- handling of a bad statement.
when others =>
-
if Token in Token_Class_Declk then
Junk_Declaration;
end;
exit when SS_Flags.Unco;
-
end loop;
return Statement_List;
-
end P_Sequence_Of_Statements;
--------------------
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;
-- 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;
-- 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;
-- 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
-- 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;
-- 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;
--------------------
-- 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;
when others =>
return OK;
-
end case;
end Process_Node;
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;
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 =>
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));
when others =>
null;
-
end case;
if Present (To_Node) then
-- 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,
-- 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
if Has_Decision (AE) then
C1 := 'X';
end if;
-
end case;
if C1 /= ASCII.NUL then
-- 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');
-- 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);
(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;
-- 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;
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.
-- 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');
-- 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;
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
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 =>
-- operator.
return T.C2 /= '?';
-
end case;
end;
end loop;
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 =>
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)) & "." &
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 =>
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 =>
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 =>
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;
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;
-- 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;
-- --
-- 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- --
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
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;
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;
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;
Set_Previous_Line_Node (Current_Declaration);
when Tok_For =>
-
Parse_Attribute_Declaration
(In_Tree => In_Tree,
Attribute => Current_Declaration,
Set_Previous_Line_Node (Current_Declaration);
when Tok_Null =>
-
Scan (In_Tree); -- past "null"
when Tok_Package =>
-- --
-- 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- --
when Spec =>
Suffix :=
Source.Language.Config.Mapping_Spec_Suffix;
- when Impl | Sep =>
+
+ when Impl
+ | Sep
+ =>
Suffix :=
Source.Language.Config.Mapping_Body_Suffix;
end case;
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,
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);
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));
& """ for Objects_Linked",
Element.Value.Location, Project);
end;
+
when others =>
null;
end case;
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
begin
case Kind is
- when Impl | Sep =>
+ when Impl
+ | Sep
+ =>
Exceptions :=
Value_Of
(Name_Implementation_Exceptions,
begin
case Kind is
- when Impl | Sep =>
+ when Impl
+ | Sep
+ =>
Exceptions :=
Value_Of
(Name_Body,
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;
end if;
end loop;
- when Mixed_Case | Unknown =>
+ when Mixed_Case
+ | Unknown
+ =>
null;
end case;
end if;
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;
-- --
-- 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- --
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;
-- --
-- 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- --
Kind_Of (The_Current_Term, From_Project_Node_Tree);
case Current_Term_Kind is
-
when N_Literal_String =>
case Kind is
when Undefined =>
(The_Current_Term, From_Project_Node_Tree);
when List =>
-
String_Element_Table.Increment_Last
(Shared.String_Elements);
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;
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;
when Single =>
case The_Variable.Kind is
-
when Undefined =>
null;
when List =>
case The_Variable.Kind is
-
when Undefined =>
null;
Index => 0);
when List =>
-
declare
The_List : String_List_Id :=
The_Variable.Values;
end if;
case Kind is
-
when Undefined =>
null;
(False,
"illegal node kind in an expression");
raise Program_Error;
-
end case;
end if;
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 =>
-- --
-- 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- --
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,
-- --
-- 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- --
-- 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
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;
Free_List (Project.Languages);
case Project.Qualifier is
- when Aggregate | Aggregate_Library =>
+ when Aggregate
+ | Aggregate_Library
+ =>
Free (Project.Aggregated_Projects);
when others =>
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;
when Discrim_Val =>
Write_Char ('#');
UI_Write (Node.Op1);
-
end case;
end;
end if;
when E_Subprogram_Type =>
Write_Str ("type ");
- when E_Entry | E_Entry_Family =>
+ when E_Entry
+ | E_Entry_Family
+ =>
Write_Str ("entry ");
when others =>
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;
pragma Assert (Sub in D'Range);
return D (Sub);
end;
-
end case;
end;
end if;
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;
-- Provide a clean environment for the unit
- Ghost_Mode := None;
+ Install_Ghost_Mode (None);
-- Note if secondary stack is used
Set_Is_Potentially_Use_Visible (U.Entity, True);
end if;
- Ghost_Mode := Save_Ghost_Mode;
+ Restore_Ghost_Mode (Save_Ghost_Mode);
end Load_RTU;
--------------------
-- --
-- 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- --
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;
-- --
-- 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- --
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;
-- --
-- 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- --
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);
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.
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;
-- 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;
-- --
-- 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- --
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);
-- 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;
-- --
-- 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- --
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;
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;
-- --
-- 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- --
-----------------
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
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;
End_State := Current_State;
end if;
- when '*' | '+' | '?' | Close_Paren | Close_Bracket =>
+ when Close_Bracket
+ | Close_Paren
+ | '*' | '+' | '?'
+ =>
Raise_Exception
("Incorrect character in regular expression :", J);
End_State := Current_State;
end if;
-
end case;
if Start_State = 0 then
J := Start_Index;
while J <= End_Index loop
case S (J) is
-
when Open_Bracket =>
Current_State := Current_State + 1;
end if;
End_State := Current_State;
-
end case;
if Start_State = 0 then
-- --
-- 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- --
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.
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);
(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;
-- --
-- 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- --
-- 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 =>
when Acceptor_Param =>
Match ("/A:([\w]+)", Input, Matches);
- when Parent_Param =>
+ when Parent_Param =>
Match ("/P:([\w]+)", Input, Matches);
when Number_Param =>
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 =>
-- --
-- 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- --
-- 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);
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);
Block.Cancelled := Entry_Call.State = Cancelled;
- when Asynchronous_Call | Timed_Call =>
+ when Asynchronous_Call
+ | Timed_Call
+ =>
pragma Assert (False);
null;
end case;
-- --
-- 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- --
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:";
-- --
-- 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- --
begin
case EM is
-
when WCEM_Hex =>
if C /= ASCII.ESC then
return Character'Pos (C);
end if;
return UTF_32_Code (B1);
-
end case;
end Char_Sequence_To_UTF_32;
-- Processing depends on encoding mode
case EM is
-
when WCEM_Hex =>
if Val < 256 then
Out_Char (Character'Val (Val));
-- --
-- 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- --
-- 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))));
-- 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));
-- 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;
-- initial character of a wide character sequence.
<<Scan_Wide_Character>>
-
declare
Code : Char_Code;
Cat : Category;
-- 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
-- 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;
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;
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.
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 =>
-- 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
-- Bit --
---------
- when Attribute_Bit => Bit :
- begin
+ when Attribute_Bit =>
Check_E0;
if not Is_Object_Reference (P) then
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;
-- Reset incorrect indication of staticness
Set_Is_Static_Expression (N, False);
- end Bit_Order;
------------------
-- Bit_Position --
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
-- Count --
-----------
- when Attribute_Count => Count :
- declare
+ when Attribute_Count => Count : declare
Ent : Entity_Id;
S : Entity_Id;
Tsk : Entity_Id;
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);
-- 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);
-- Enum_Rep --
--------------
- when Attribute_Enum_Rep => Enum_Rep : declare
- begin
+ when Attribute_Enum_Rep =>
if Present (E1) then
Check_E1;
Check_Discrete_Type;
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;
Resolve (E1, Any_Integer);
Set_Etype (N, P_Base_Type);
end if;
- end Enum_Val;
-------------
-- Epsilon --
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");
-- 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
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);
then
Check_Restriction (No_Fixed_IO, P);
end if;
- end Img;
-----------
-- Input --
-- Partition_ID --
------------------
- when Attribute_Partition_ID => Partition_Id :
- begin
+ when Attribute_Partition_ID =>
Check_E0;
if P_Type /= Any_Type then
end if;
Set_Etype (N, Universal_Integer);
- end Partition_Id;
-------------------------
-- Passed_By_Reference --
-- 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
-- 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
Rewrite (N, Make_Integer_Literal (Sloc (N), Esize (Entity (P))));
Analyze (N);
end if;
- end Size;
-----------
-- Small --
-- 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
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
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
else
Error_Attr_P ("prefix of % attribute must be access or task type");
end if;
- end Storage_Size;
------------------
-- Storage_Unit --
-- Tag --
---------
- when Attribute_Tag => Tag :
- begin
+ when Attribute_Tag =>
Check_E0;
Check_Dereference;
-- Set appropriate type
Set_Etype (N, RTE (RE_Tag));
- end Tag;
-----------------
-- Target_Name --
-- 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)
Set_Is_Static_Expression (N, True);
end;
end if;
- end Universal_Literal_String;
-------------------------
-- Unrestricted_Access --
-- Val --
---------
- when Attribute_Val => Val : declare
- begin
+ when Attribute_Val =>
Check_E1;
Check_Discrete_Type;
("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 --
-- Value --
-----------
- when Attribute_Value => Value :
- begin
+ when Attribute_Value =>
Check_SPARK_05_Restriction_On_Attribute;
Check_E1;
Check_Scalar_Type;
then
Check_Restriction (No_Fixed_IO, P);
end if;
- end Value;
----------------
-- Value_Size --
-- 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);
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;
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;
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;
then
Check_Restriction (No_Fixed_IO, P);
end if;
- end Wide_Wide_Value;
---------------------
-- Wide_Wide_Width --
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 =>
-- 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
-- First --
-----------
- when Attribute_First => First_Attr :
- begin
+ when Attribute_First =>
Set_Bounds;
if Compile_Time_Known_Value (Lo_Bound) then
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
Set_Bounds;
Fold_Uint (N, Expr_Value (Lo_Bound), Static);
end if;
- end First_Valid;
-----------------
-- Fixed_Value --
-- Last --
----------
- when Attribute_Last => Last_Attr :
- begin
+ when Attribute_Last =>
Set_Bounds;
if Compile_Time_Known_Value (Hi_Bound) then
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
Set_Bounds;
Fold_Uint (N, Expr_Value (Hi_Bound), Static);
end if;
- end Last_Valid;
------------------
-- Leading_Part --
-- 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 --
-- 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 --
-- 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);
Fold_Uint
(N, UI_Min (Expr_Value (E1), Expr_Value (E2)), Static);
end if;
- end Min;
---------
-- Mod --
-- Pred --
----------
- when Attribute_Pred => Pred :
- begin
+ when Attribute_Pred =>
+
-- Floating-point case
if Is_Floating_Point_Type (P_Type) then
Fold_Uint (N, Expr_Value (E1) - 1, Static);
end if;
- end Pred;
-----------
-- Range --
-- 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
-- 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 --
-- 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;
-- 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 --
-- Succ --
----------
- when Attribute_Succ => Succ :
- begin
+ when Attribute_Succ =>
-- Floating-point case
if Is_Floating_Point_Type (P_Type) then
Fold_Uint (N, Expr_Value (E1) + 1, Static);
end if;
end if;
- end Succ;
----------------
-- Truncation --
-- 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))
else
Fold_Uint (N, Expr_Value (E1), Static);
end if;
- end Val;
----------------
-- Value_Size --
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);
-- 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
-- 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#)
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
-- 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;
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
end if;
end;
end if;
- end Access_Attribute;
-------------
-- Address --
-- 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.
end if;
end;
end if;
- end Address_Attribute;
------------------
-- Body_Version --
-- 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 --
-- 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 --
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;
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;
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 =>
-- --
-- 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- --
when others =>
null;
-
end case;
end if;
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;
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));
-- 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 =>
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;
Kind := Nkind (Analyzed_Formal);
case Nkind (Formal) is
-
when N_Formal_Subprogram_Declaration =>
exit when Kind in N_Formal_Subprogram_Declaration
and then
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 =>
-- 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
when others =>
raise Program_Error;
-
end case;
Formal := Saved_Formal;
-- 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;
-- 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);
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
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
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;
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 =>
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;
-- 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
when others =>
pragma Assert (Aspect_Delay (A_Id) /= Rep_Aspect);
null;
-
end case;
end if;
end if;
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;
-- 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
-- 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
-- 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
-- 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
-- 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,
-- 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
-- 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;
-- 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
-- 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.
-- 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
-- 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;
-- 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
-- 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);
end if;
end if;
end if;
- end Bit_Order;
--------------------
-- Component_Size --
-- CPU --
---------
- when Attribute_CPU => CPU :
- begin
+ when Attribute_CPU =>
+
-- CPU attribute definition clause not allowed except from aspect
-- specification.
Error_Msg_N
("attribute& cannot be set with definition clause", N);
end if;
- end CPU;
----------------------
-- Default_Iterator --
-- Dispatching_Domain --
------------------------
- when Attribute_Dispatching_Domain => Dispatching_Domain :
- begin
+ when Attribute_Dispatching_Domain =>
+
-- Dispatching_Domain attribute definition clause not allowed
-- except from aspect specification.
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;
("\??corresponding internal tag cannot be obtained", N);
end if;
end if;
- end External_Tag;
--------------------------
-- Implicit_Dereference --
-- Interrupt_Priority --
------------------------
- when Attribute_Interrupt_Priority => Interrupt_Priority :
- begin
+ when Attribute_Interrupt_Priority =>
+
-- Interrupt_Priority attribute definition clause not allowed
-- except from aspect specification.
Error_Msg_N
("attribute& cannot be set with definition clause", N);
end if;
- end Interrupt_Priority;
--------------
-- Iterable --
-- Priority --
--------------
- when Attribute_Priority => Priority :
- begin
+ when Attribute_Priority =>
+
-- Priority attribute definition clause not allowed except from
-- aspect specification.
Error_Msg_N
("attribute& cannot be set with definition clause", N);
end if;
- end Priority;
----------
-- Read --
-- 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 "
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.
Error_Msg_N
("attribute& cannot be set with definition clause", N);
end if;
- end Secondary_Stack_Size;
----------
-- Size --
-- 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;
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);
Error_Msg_N ("incorrect reference to a Storage Pool", Expr);
return;
end if;
- end;
+ end Storage_Pool;
------------------
-- Storage_Size --
-- 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));
-- 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
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 =>
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 =>
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 =>
-- 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;
-- 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 =>
-- 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;
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))
("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;
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
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 =>
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 =>
-- 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.
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;
when others =>
return False;
-
end case;
end Contains_POC;
when others =>
raise Program_Error;
-
end case;
end if;
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);
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
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:
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);
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;
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
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 =>
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 =>
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 =>
-- 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
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
-- 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;
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;
-- 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);
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;
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;
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);
-- 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 =>
-- 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)
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;
else
case Nkind (E1) is
-
when N_Aggregate =>
return
FCL (Expressions (E1), Expressions (E2))
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
when others =>
return True;
-
end case;
end if;
end Fully_Conformant_Expressions;
-- 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);
-- 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;
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;
-- 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);
-- 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)
-- 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)
-- 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);
-- 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;
-----------------------------------
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
return False;
end if;
- when others => return False;
+ when others =>
+ return False;
end case;
end Is_Static_Function;
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;
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;
when N_Unary_Op =>
Analyze_Dimension_Unary_Op (N);
- when others => null;
-
+ when others =>
+ null;
end case;
end Analyze_Dimension;
-- 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);
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;
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;
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
-- All other character doesn't belong to a numeric literal
- when others =>
+ when others =>
return False;
end case;
end Belong_To_Numeric_Literal;
-- --
-- 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- --
---------------------------------
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;
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);
-- 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
-- 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));
-- 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
when others =>
null;
-
end case;
end Why_Not_Static;
-- --
-- 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- --
-- 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
-- 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))
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);
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;
-- 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
-- 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
-- ( [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
-- 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;
-- 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;
-- 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);
E : Entity_Id;
pragma Warnings (Off, C);
pragma Warnings (Off, E);
+
begin
Check_Arg_Order ((Name_Convention, Name_Entity));
Check_Ada_83_Warning;
-- 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
Expression => Make_Identifier (Loc, Name_CPP)),
New_Copy (First (Pragma_Argument_Associations (N))))));
Analyze (N);
- end CPP_Class;
---------------------
-- CPP_Constructor --
-- CPP_Virtual --
-----------------
- when Pragma_CPP_Virtual => CPP_Virtual : declare
- begin
+ when Pragma_CPP_Virtual =>
GNAT_Pragma;
if Warn_On_Obsolescent_Feature then
("'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
("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
& "effect?j?", N);
end if;
- end CPP_Vtable;
---------
-- CPU --
-- 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);
else
Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
end if;
- end Extend_System;
------------------------
-- Extensions_Allowed --
-- 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;
when others =>
null;
end case;
- end External_Name_Casing;
---------------
-- Fast_Math --
-- 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
-- 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;
-- 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
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 /= ' '
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;
-- 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;
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 /= ' '
Partition_Elaboration_Policy_Sloc := Loc;
end if;
end if;
- end;
+ end PEP;
-------------
-- Passive --
-- 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;
--------------------------------
-- 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;
---------------
-- [, [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) := (
-- [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
-- ([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;
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);
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;
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;
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;
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))
-- 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);
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 =>
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
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 =>
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 =>
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
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;
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;
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;
end loop;
end;
- when N_Aggregate |
- N_Extension_Aggregate =>
+ when N_Aggregate
+ | N_Extension_Aggregate
+ =>
declare
Assoc : Node_Id;
Choice : Node_Id;
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 "
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);
end if;
end;
- when N_Block_Statement |
- N_Loop_Statement =>
+ when N_Block_Statement
+ | N_Loop_Statement
+ =>
return Entity (Identifier (N));
when others =>
else
raise Program_Error;
end if;
-
end case;
end Defining_Entity;
-- 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
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;
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.
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;
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)));
when others =>
return False;
-
end case;
end Has_Null_Exclusion;
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;
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)));
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;
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;
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));
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 =>
-- 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;
when others =>
return False;
-
end case;
end Known_To_Be_Assigned;
-- 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
-- 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;
when others =>
return False;
-
end case;
end May_Be_Lvalue;
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
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)));
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;
-- 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)
-- 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
-- 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);
-- 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
-- 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
when others =>
null;
-
end case;
end Check_Unset_Reference;
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
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);
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
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) & ");");
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 (' ');
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;
-- 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.
-- FUNCTION or PROCEDURE
- when Tok_Procedure | Tok_Function =>
+ when Tok_Function
+ | Tok_Procedure
+ =>
Pcount := 0;
-- Loop through tokens following PROCEDURE or FUNCTION
-- 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
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;
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 ");
Write_Ekind (E);
Write_Str (">;");
end case;
-
end Write_Implicit_Def;
------------------
-- 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
-- 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
-- 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;
-- 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");
when others =>
Write_Header (True);
Write_Str ("???");
-
end case;
end if;
if On then
case C is
-
when '+' =>
null;
else
case C is
-
when '+' =>
On := True;
-- Processing for a switch
case Switch_Starts_With_Gnat is
-
when False =>
-- All switches that don't start with -gnat stay as 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));
else
case Switch_Chars (Ptr) is
-
when 'A' =>
Ptr := Ptr + 1;
Add_Switch_Component ("-gnateA");
when others =>
Last := 0;
return;
-
end case;
-
end case;
end loop;
end Normalize_Compiler_Switches;
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
else
Check_Switch : begin
-
case C is
-
when 'a' =>
Check_Readonly_Files := True;
else
Success := False;
end if;
-
end case;
end Check_Switch;
end if;
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 =>
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 =>
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;
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;
Hash_Slot := H;
Hash_Table (H).Id := Id;
return 0;
-
end Serial_Number;
-----------------------
-- --
-- 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- --
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))));
-- 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;
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 =>
-- --
-- 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- --
Validity_Checks_On := True;
case C is
-
when 'c' =>
Validity_Check_Copies := True;
Err_Col := J - 1;
return;
end if;
-
end case;
end loop;
-- --
-- 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- --
-- 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;
-- --
-- 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- --
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);
-- --
-- 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- --
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' =>
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;
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;
projects / gcc.git / commitdiff