Skip to content

R
riscv-gcc-1
Commit 727e7b1a by Arnaud Charlet
Options

[multiple changes] 

2012-07-12  Robert Dewar  <dewar@adacore.com>

	* s-atopri.adb, s-atopri.ads: Minor reformatting.

2012-07-12  Robert Dewar  <dewar@adacore.com>

	* ali.adb: Add circuitry to read new named form of restrictions lines.
	* debug.adb: Add doc for new -gnatd.R switch (used positional
	notation for output of restrictions data in ali file).
	* lib-writ.adb: Implement new named format for restrictions lines.
	* lib-writ.ads: Add documentation for new named format for
	restrictions in ali files.
	* restrict.adb, restrict.ads, sem_prag.adb: Update comments.
	* rident.ads: Go back to withing System.Rident
	* s-rident.ads: Add extensive comment on dealing with consistency
	checking.

2012-07-12  Thomas Quinot  <quinot@adacore.com>

	* par_sco.adb, scos.ads: Emit detailed SCOs for SELECT statements.

From-SVN: r189438
parent 03459f40
Showing with 1072 additions and 910 deletions
gcc/ada/ChangeLog
2012-07-12 Robert Dewar <dewar@adacore.com> 2012-07-12 Robert Dewar <dewar@adacore.com>
* s-atopri.adb, s-atopri.ads: Minor reformatting.
2012-07-12 Robert Dewar <dewar@adacore.com>
* ali.adb: Add circuitry to read new named form of restrictions lines.
* debug.adb: Add doc for new -gnatd.R switch (used positional
notation for output of restrictions data in ali file).
* lib-writ.adb: Implement new named format for restrictions lines.
* lib-writ.ads: Add documentation for new named format for
restrictions in ali files.
* restrict.adb, restrict.ads, sem_prag.adb: Update comments.
* rident.ads: Go back to withing System.Rident
* s-rident.ads: Add extensive comment on dealing with consistency
checking.
2012-07-12 Thomas Quinot <quinot@adacore.com>
* par_sco.adb, scos.ads: Emit detailed SCOs for SELECT statements.
2012-07-12 Robert Dewar <dewar@adacore.com>
* sem_disp.adb: Minor reformatting * sem_disp.adb: Minor reformatting
* s-bytswa.ads: Minor comment update. * s-bytswa.ads: Minor comment update.
......
gcc/ada/ali.adb
...@@ -135,7 +135,7 @@ package body ALI is ...@@ -135,7 +135,7 @@ package body ALI is
Ignore_Errors : Boolean := False; Ignore_Errors : Boolean := False;
Directly_Scanned : Boolean := False) return ALI_Id Directly_Scanned : Boolean := False) return ALI_Id
is is
P : Text_Ptr := T'First; P : Text_Ptr := T'First;
Line : Logical_Line_Number := 1; Line : Logical_Line_Number := 1;
Id : ALI_Id; Id : ALI_Id;
C : Character; C : Character;
...@@ -1154,7 +1154,7 @@ package body ALI is ...@@ -1154,7 +1154,7 @@ package body ALI is
C := Getc; C := Getc;
Check_Unknown_Line; Check_Unknown_Line;
-- Acquire first restrictions line -- Loop to skip to first restrictions line
while C /= 'R' loop while C /= 'R' loop
if Ignore_Errors then if Ignore_Errors then
...@@ -1169,10 +1169,15 @@ package body ALI is ...@@ -1169,10 +1169,15 @@ package body ALI is
end if; end if;
end loop; end loop;
-- Ignore all 'R' lines if that is required
if Ignore ('R') then if Ignore ('R') then
Skip_Line; while C = 'R' loop
Skip_Line;
C := Getc;
end loop;
-- Process restrictions line -- Here we process the restrictions lines (other than unit name cases)
else else
Scan_Restrictions : declare Scan_Restrictions : declare
...@@ -1182,16 +1187,191 @@ package body ALI is ...@@ -1182,16 +1187,191 @@ package body ALI is
Bad_R_Line : exception; Bad_R_Line : exception;
-- Signal bad restrictions line (raised on unexpected character) -- Signal bad restrictions line (raised on unexpected character)
begin Typ : Character;
Checkc (' '); R : Restriction_Id;
Skip_Space; N : Natural;
-- Acquire information for boolean restrictions begin
-- Named restriction case
for R in All_Boolean_Restrictions loop if Nextc = 'N' then
Skip_Line;
C := Getc; C := Getc;
case C is -- Loop through RR and RV lines
while C = 'R' and then Nextc /= ' ' loop
Typ := Getc;
Checkc (' ');
-- Acquire restriction name
Name_Len := 0;
while not At_Eol and then Nextc /= '=' loop
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Getc;
end loop;
-- Now search list of restrictions to find match
declare
RN : String renames Name_Buffer (1 .. Name_Len);
begin
R := Restriction_Id'First;
while R < Not_A_Restriction_Id loop
if Restriction_Id'Image (R) = RN then
goto R_Found;
end if;
R := Restriction_Id'Succ (R);
end loop;
-- We don't recognize the restriction. This might be
-- thought of as an error, and it really is, but we
-- want to allow building with inconsistent versions
-- of the binder and ali files (see comments at the
-- start of package System.Rident), so we just ignore
-- this situation.
goto Done_With_Restriction_Line;
end;
<<R_Found>>
case R is
-- Boolean restriction case
when All_Boolean_Restrictions =>
case Typ is
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 others =>
raise Bad_R_Line;
end case;
-- Parameter restriction case
when All_Parameter_Restrictions =>
if At_Eol or else Nextc /= '=' then
raise Bad_R_Line;
else
Skipc;
end if;
N := Natural (Get_Nat);
case Typ is
-- Restriction set
when 'R' =>
ALIs.Table (Id).Restrictions.Set (R) := True;
ALIs.Table (Id).Restrictions.Value (R) := N;
if Cumulative_Restrictions.Set (R) then
Cumulative_Restrictions.Value (R) :=
Integer'Min
(Cumulative_Restrictions.Value (R), N);
else
Cumulative_Restrictions.Set (R) := True;
Cumulative_Restrictions.Value (R) := N;
end if;
-- Restriction violated
when 'V' =>
ALIs.Table (Id).Restrictions.Violated (R) :=
True;
Cumulative_Restrictions.Violated (R) := True;
ALIs.Table (Id).Restrictions.Count (R) := N;
-- Checked Max_Parameter case
if R in Checked_Max_Parameter_Restrictions then
Cumulative_Restrictions.Count (R) :=
Integer'Max
(Cumulative_Restrictions.Count (R), N);
-- Other checked parameter cases
else
declare
pragma Unsuppress (Overflow_Check);
begin
Cumulative_Restrictions.Count (R) :=
Cumulative_Restrictions.Count (R) + N;
exception
when Constraint_Error =>
-- A constraint error comes from the
-- additionh. We reset to the maximum
-- and indicate that the real value is
-- now unknown.
Cumulative_Restrictions.Value (R) :=
Integer'Last;
Cumulative_Restrictions.Unknown (R) :=
True;
end;
end if;
-- Deal with + case
if Nextc = '+' then
Skipc;
ALIs.Table (Id).Restrictions.Unknown (R) :=
True;
Cumulative_Restrictions.Unknown (R) := True;
end if;
-- Other than 'R' or 'V'
when others =>
raise Bad_R_Line;
end case;
if not At_Eol then
raise Bad_R_Line;
end if;
-- Bizarre error case NOT_A_RESTRICTION
when Not_A_Restriction_Id =>
raise Bad_R_Line;
end case;
if not At_Eol then
raise Bad_R_Line;
end if;
<<Done_With_Restriction_Line>>
Skip_Line;
C := Getc;
end loop;
-- Positional restriction case
else
Checkc (' ');
Skip_Space;
-- Acquire information for boolean restrictions
for R in All_Boolean_Restrictions loop
C := Getc;
case C is
when 'v' => when 'v' =>
ALIs.Table (Id).Restrictions.Violated (R) := True; ALIs.Table (Id).Restrictions.Violated (R) := True;
Cumulative_Restrictions.Violated (R) := True; Cumulative_Restrictions.Violated (R) := True;
...@@ -1205,44 +1385,42 @@ package body ALI is ...@@ -1205,44 +1385,42 @@ package body ALI is
when others => when others =>
raise Bad_R_Line; raise Bad_R_Line;
end case; end case;
end loop; end loop;
-- Acquire information for parameter restrictions
for RP in All_Parameter_Restrictions loop -- Acquire information for parameter restrictions
-- Acquire restrictions pragma information for RP in All_Parameter_Restrictions loop
case Getc is
when 'n' =>
null;
case Getc is when 'r' =>
when 'n' => ALIs.Table (Id).Restrictions.Set (RP) := True;
null;
when 'r' => declare
ALIs.Table (Id).Restrictions.Set (RP) := True; N : constant Integer := Integer (Get_Nat);
begin
ALIs.Table (Id).Restrictions.Value (RP) := N;
declare if Cumulative_Restrictions.Set (RP) then
N : constant Integer := Integer (Get_Nat); Cumulative_Restrictions.Value (RP) :=
begin Integer'Min
ALIs.Table (Id).Restrictions.Value (RP) := N; (Cumulative_Restrictions.Value (RP), N);
else
Cumulative_Restrictions.Set (RP) := True;
Cumulative_Restrictions.Value (RP) := N;
end if;
end;
if Cumulative_Restrictions.Set (RP) then when others =>
Cumulative_Restrictions.Value (RP) := raise Bad_R_Line;
Integer'Min end case;
(Cumulative_Restrictions.Value (RP), N);
else
Cumulative_Restrictions.Set (RP) := True;
Cumulative_Restrictions.Value (RP) := N;
end if;
end;
when others => -- Acquire restrictions violations information
raise Bad_R_Line;
end case;
-- Acquire restrictions violations information case Getc is
case Getc is
when 'n' => when 'n' =>
null; null;
...@@ -1252,7 +1430,6 @@ package body ALI is ...@@ -1252,7 +1430,6 @@ package body ALI is
declare declare
N : constant Integer := Integer (Get_Nat); N : constant Integer := Integer (Get_Nat);
pragma Unsuppress (Overflow_Check);
begin begin
ALIs.Table (Id).Restrictions.Count (RP) := N; ALIs.Table (Id).Restrictions.Count (RP) := N;
...@@ -1261,34 +1438,47 @@ package body ALI is ...@@ -1261,34 +1438,47 @@ package body ALI is
Cumulative_Restrictions.Count (RP) := Cumulative_Restrictions.Count (RP) :=
Integer'Max Integer'Max
(Cumulative_Restrictions.Count (RP), N); (Cumulative_Restrictions.Count (RP), N);
else else
Cumulative_Restrictions.Count (RP) := declare
Cumulative_Restrictions.Count (RP) + N; pragma Unsuppress (Overflow_Check);
end if;
exception begin
when Constraint_Error => Cumulative_Restrictions.Count (RP) :=
Cumulative_Restrictions.Count (RP) + N;
exception
when Constraint_Error =>
-- A constraint error comes from the addition in -- A constraint error comes from the add. We
-- the else branch. We reset to the maximum and -- reset to the maximum and indicate that the
-- indicate that the real value is now unknown. -- real value is now unknown.
Cumulative_Restrictions.Value (RP) :=
Integer'Last;
Cumulative_Restrictions.Unknown (RP) := True;
end;
end if;
Cumulative_Restrictions.Value (RP) := Integer'Last; if Nextc = '+' then
Skipc;
ALIs.Table (Id).Restrictions.Unknown (RP) := True;
Cumulative_Restrictions.Unknown (RP) := True; Cumulative_Restrictions.Unknown (RP) := True;
end if;
end; end;
if Nextc = '+' then
Skipc;
ALIs.Table (Id).Restrictions.Unknown (RP) := True;
Cumulative_Restrictions.Unknown (RP) := True;
end if;
when others => when others =>
raise Bad_R_Line; raise Bad_R_Line;
end case; end case;
end loop; end loop;
Skip_Eol; if not At_Eol then
raise Bad_R_Line;
else
Skip_Line;
C := Getc;
end if;
end if;
-- Here if error during scanning of restrictions line -- Here if error during scanning of restrictions line
...@@ -1296,25 +1486,29 @@ package body ALI is ...@@ -1296,25 +1486,29 @@ package body ALI is
when Bad_R_Line => when Bad_R_Line =>
-- In Ignore_Errors mode, undo any changes to restrictions -- In Ignore_Errors mode, undo any changes to restrictions
-- from this unit, and continue on. -- from this unit, and continue on, skipping remaining R
-- lines for this unit.
if Ignore_Errors then if Ignore_Errors then
Cumulative_Restrictions := Save_R; Cumulative_Restrictions := Save_R;
ALIs.Table (Id).Restrictions := No_Restrictions; ALIs.Table (Id).Restrictions := No_Restrictions;
Skip_Eol;
loop
Skip_Eol;
C := Getc;
exit when C /= 'R';
end loop;
-- In normal mode, this is a fatal error -- In normal mode, this is a fatal error
else else
Fatal_Error; Fatal_Error;
end if; end if;
end Scan_Restrictions; end Scan_Restrictions;
end if; end if;
-- Acquire additional restrictions (No_Dependence) lines if present -- Acquire additional restrictions (No_Dependence) lines if present
C := Getc;
while C = 'R' loop while C = 'R' loop
if Ignore ('R') then if Ignore ('R') then
Skip_Line; Skip_Line;
......
gcc/ada/debug.adb
...@@ -135,7 +135,7 @@ package body Debug is ...@@ -135,7 +135,7 @@ package body Debug is
-- d.O Dump internal SCO tables -- d.O Dump internal SCO tables
-- d.P Previous (non-optimized) handling of length comparisons -- d.P Previous (non-optimized) handling of length comparisons
-- d.Q -- d.Q
-- d.R -- d.R Restrictions in ali files in positional form
-- d.S Force Optimize_Alignment (Space) -- d.S Force Optimize_Alignment (Space)
-- d.T Force Optimize_Alignment (Time) -- d.T Force Optimize_Alignment (Time)
-- d.U Ignore indirect calls for static elaboration -- d.U Ignore indirect calls for static elaboration
...@@ -642,6 +642,11 @@ package body Debug is ...@@ -642,6 +642,11 @@ package body Debug is
-- This is there in case we find a situation where the optimization -- This is there in case we find a situation where the optimization
-- malfunctions, to provide a work around. -- malfunctions, to provide a work around.
-- d.R As documented in lib-writ.ads, restrictions in the ali file can
-- have two forms, positional and named. The named notation is the
-- current preferred form, but the use of this debug switch will force
-- the use of the obsolescent positional form.
-- d.S Force Optimize_Alignment (Space) mode as the default -- d.S Force Optimize_Alignment (Space) mode as the default
-- d.T Force Optimize_Alignment (Time) mode as the default -- d.T Force Optimize_Alignment (Time) mode as the default
......
gcc/ada/lib-writ.adb
...@@ -26,6 +26,7 @@ ...@@ -26,6 +26,7 @@
with ALI; use ALI; with ALI; use ALI;
with Atree; use Atree; with Atree; use Atree;
with Casing; use Casing; with Casing; use Casing;
with Debug; use Debug;
with Einfo; use Einfo; with Einfo; use Einfo;
with Errout; use Errout; with Errout; use Errout;
with Fname; use Fname; with Fname; use Fname;
...@@ -1140,52 +1141,128 @@ package body Lib.Writ is ...@@ -1140,52 +1141,128 @@ package body Lib.Writ is
end if; end if;
end loop; end loop;
-- Output first restrictions line -- Positional case (only if debug flag -gnatd.R is set)
Write_Info_Initiate ('R'); if Debug_Flag_Dot_RR then
Write_Info_Char (' ');
-- First the information for the boolean restrictions -- Output first restrictions line
for R in All_Boolean_Restrictions loop Write_Info_Initiate ('R');
if Main_Restrictions.Set (R) Write_Info_Char (' ');
and then not Restriction_Warnings (R)
then
Write_Info_Char ('r');
elsif Main_Restrictions.Violated (R) then
Write_Info_Char ('v');
else
Write_Info_Char ('n');
end if;
end loop;
-- And now the information for the parameter restrictions -- First the information for the boolean restrictions
for RP in All_Parameter_Restrictions loop for R in All_Boolean_Restrictions loop
if Main_Restrictions.Set (RP) if Main_Restrictions.Set (R)
and then not Restriction_Warnings (RP) and then not Restriction_Warnings (R)
then then
Write_Info_Char ('r'); Write_Info_Char ('r');
Write_Info_Nat (Nat (Main_Restrictions.Value (RP))); elsif Main_Restrictions.Violated (R) then
else Write_Info_Char ('v');
Write_Info_Char ('n'); else
end if; Write_Info_Char ('n');
end if;
end loop;
if not Main_Restrictions.Violated (RP) -- And now the information for the parameter restrictions
or else RP not in Checked_Parameter_Restrictions
then for RP in All_Parameter_Restrictions loop
Write_Info_Char ('n'); if Main_Restrictions.Set (RP)
else and then not Restriction_Warnings (RP)
Write_Info_Char ('v'); then
Write_Info_Nat (Nat (Main_Restrictions.Count (RP))); Write_Info_Char ('r');
Write_Info_Nat (Nat (Main_Restrictions.Value (RP)));
else
Write_Info_Char ('n');
end if;
if not Main_Restrictions.Violated (RP)
or else RP not in Checked_Parameter_Restrictions
then
Write_Info_Char ('n');
else
Write_Info_Char ('v');
Write_Info_Nat (Nat (Main_Restrictions.Count (RP)));
if Main_Restrictions.Unknown (RP) then if Main_Restrictions.Unknown (RP) then
Write_Info_Char ('+'); Write_Info_Char ('+');
end if;
end if; end if;
end if; end loop;
end loop;
Write_Info_EOL; Write_Info_EOL;
-- Named case (if debug flag -gnatd.R is not set)
else
declare
C : Character;
begin
-- Write RN header line with preceding blank line
Write_Info_EOL;
Write_Info_Initiate ('R');
Write_Info_Char ('N');
Write_Info_EOL;
-- First the lines for the boolean restrictions
for R in All_Boolean_Restrictions loop
if Main_Restrictions.Set (R)
and then not Restriction_Warnings (R)
then
C := 'R';
elsif Main_Restrictions.Violated (R) then
C := 'V';
else
goto Continue;
end if;
Write_Info_Initiate ('R');
Write_Info_Char (C);
Write_Info_Char (' ');
Write_Info_Str (All_Boolean_Restrictions'Image (R));
Write_Info_EOL;
<<Continue>>
null;
end loop;
end;
-- And now the lines for the parameter restrictions
for RP in All_Parameter_Restrictions loop
if Main_Restrictions.Set (RP)
and then not Restriction_Warnings (RP)
then
Write_Info_Initiate ('R');
Write_Info_Str ("R ");
Write_Info_Str (All_Parameter_Restrictions'Image (RP));
Write_Info_Char ('=');
Write_Info_Nat (Nat (Main_Restrictions.Value (RP)));
Write_Info_EOL;
end if;
if not Main_Restrictions.Violated (RP)
or else RP not in Checked_Parameter_Restrictions
then
null;
else
Write_Info_Initiate ('R');
Write_Info_Str ("V ");
Write_Info_Str (All_Parameter_Restrictions'Image (RP));
Write_Info_Char ('=');
Write_Info_Nat (Nat (Main_Restrictions.Count (RP)));
if Main_Restrictions.Unknown (RP) then
Write_Info_Char ('+');
end if;
Write_Info_EOL;
end if;
end loop;
end if;
-- Output R lines for No_Dependence entries -- Output R lines for No_Dependence entries
......
gcc/ada/lib-writ.ads
...@@ -262,6 +262,28 @@ package Lib.Writ is ...@@ -262,6 +262,28 @@ package Lib.Writ is
-- -- R Restrictions -- -- -- R Restrictions --
-- --------------------- -- ---------------------
-- There are two forms for R lines, positional and named. The positional
-- notation is now considered obsolescent, it is not generated by the most
-- recent versions of the compiler except under control of the debug switch
-- -gnatdR, but is still recognized by the binder.
-- The recognition by the binder is to ease the transition, and better deal
-- with some cases of inconsistent builds using incompatible versions of
-- the compiler and binder. The named notation is the current preferred
-- approach.
-- Note that R lines are generated using the information in unit Rident,
-- and intepreted by the binder using the information in System.Rident.
-- Normally these two units should be effectively identical. However in
-- some cases of inconsistent builds, they may be different. This may lead
-- to binder diagnostics, which can be suppressed using the -C switch for
-- the binder, which results in ignoring unrecognized restrictions in the
-- ali files.
-- ---------------------------------------
-- -- R Restrictions (Positional Form) --
-- ---------------------------------------
-- The first R line records the status of restrictions generated by pragma -- The first R line records the status of restrictions generated by pragma
-- Restrictions encountered, as well as information on what the compiler -- Restrictions encountered, as well as information on what the compiler
-- has been able to determine with respect to restrictions violations. -- has been able to determine with respect to restrictions violations.
...@@ -348,6 +370,74 @@ package Lib.Writ is ...@@ -348,6 +370,74 @@ package Lib.Writ is
-- signal a fatal error if it is missing. This means that future -- signal a fatal error if it is missing. This means that future
-- changes to the ALI file format must retain the R line. -- changes to the ALI file format must retain the R line.
-- ----------------------------------
-- -- R Restrictions (Named Form) --
-- ----------------------------------
-- The first R line for named form announces that named notation will be
-- used, and also assures that there is at least one R line present, which
-- makes parsing of ali files simpler. A blank line preceds the RN line.
-- RN
-- In named notation, the restrictions are given as a series of lines, one
-- per retrictions that is specified or violated (no information is present
-- for restrictions that are not specified or violated). In the following
-- name is the name of the restriction in all upper case.
-- For boolean restrictions, we have only two possibilities. A restrictions
-- pragma is present, or a violation is detected:
-- RR name
-- A restriction pragma is present for the named boolean restriction.
-- No violations were detected by the compiler (or the unit in question
-- would have been found to be illegal).
-- RV name
-- No restriction pragma is present for the named boolean restriction.
-- However, the compiler did detect one or more violations of this
-- restriction, which may require a binder consistency check.
-- For the case of restrictions that take a parameter, we need both the
-- information from pragma if present, and the actual information about
-- what possible violations occur. For example, we can have a unit with
-- a pragma Restrictions (Max_Tasks => 4), where the compiler can detect
-- that there are exactly three tasks declared. Both of these pieces
-- of information must be passed to the binder. The parameter of 4 is
-- important in case the total number of tasks in the partition is greater
-- than 4. The parameter of 3 is important in case some other unit has a
-- restrictions pragma with Max_Tasks=>2.
-- RR name=N
-- A restriction pragma is present for the named restriction which is
-- one of the restrictions taking a parameter. The value N (a decimal
-- integer) is the value given in the restriction pragma.
-- RV name=N
-- A restriction pragma may or may not be present for the restriction
-- given by name (one of the restrictions taking a parameter). But in
-- either case, the compiler detected possible violations. N (a decimal
-- integer) is the maximum or total count of violations (depending
-- on the checking type) in all the units represented by the ali file).
-- The value here is known to be exact by the compiler and is in the
-- range of Natural. Note that if an RR line is present for the same
-- restriction, then the value in the RV line cannot exceed the value
-- in the RR line (since otherwise the compiler would have detected a
-- violation of the restriction).
-- RV name=N+
-- Similar to the above, but the compiler cannot determine the exact
-- count of violations, but it is at least N.
-- -------------------------------------------------
-- -- R Restrictions (No_Dependence Information) --
-- -------------------------------------------------
-- Subsequent R lines are present only if pragma Restriction No_Dependence -- Subsequent R lines are present only if pragma Restriction No_Dependence
-- is used. There is one such line for each such pragma appearing in the -- is used. There is one such line for each such pragma appearing in the
-- extended main unit. The format is: -- extended main unit. The format is:
......
gcc/ada/par_sco.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2009-2011, Free Software Foundation, Inc. -- -- Copyright (C) 2009-2012, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -69,9 +69,9 @@ package body Par_SCO is ...@@ -69,9 +69,9 @@ package body Par_SCO is
-- We need to be able to get to conditions quickly for handling the calls -- We need to be able to get to conditions quickly for handling the calls
-- to Set_SCO_Condition efficiently, and similarly to get to pragmas to -- to Set_SCO_Condition efficiently, and similarly to get to pragmas to
-- handle calls to Set_SCO_Pragma_Enabled. For this purpose we identify -- handle calls to Set_SCO_Pragma_Enabled. For this purpose we identify the
-- the conditions and pragmas in the table by their starting sloc, and use -- conditions and pragmas in the table by their starting sloc, and use this
-- this hash table to map from these sloc values to SCO_Table indexes. -- hash table to map from these sloc values to SCO_Table indexes.
type Header_Num is new Integer range 0 .. 996; type Header_Num is new Integer range 0 .. 996;
-- Type for hash table headers -- Type for hash table headers
...@@ -133,13 +133,16 @@ package body Par_SCO is ...@@ -133,13 +133,16 @@ package body Par_SCO is
-- F/T/S/E for a valid dominance marker, or ' ' for no dominant -- F/T/S/E for a valid dominance marker, or ' ' for no dominant
N : Node_Id; N : Node_Id;
-- Node providing the sloc(s) for the dominance marker -- Node providing the Sloc(s) for the dominance marker
end record; end record;
No_Dominant : constant Dominant_Info := (' ', Empty); No_Dominant : constant Dominant_Info := (' ', Empty);
procedure Traverse_Declarations_Or_Statements procedure Traverse_Declarations_Or_Statements
(L : List_Id; (L : List_Id;
D : Dominant_Info := No_Dominant); D : Dominant_Info := No_Dominant;
P : Node_Id := Empty);
-- Process L, a list of statements or declarations dominated by D.
-- If P is present, it is processed as though it had been prepended to L.
procedure Traverse_Generic_Instantiation (N : Node_Id); procedure Traverse_Generic_Instantiation (N : Node_Id);
procedure Traverse_Generic_Package_Declaration (N : Node_Id); procedure Traverse_Generic_Package_Declaration (N : Node_Id);
...@@ -328,9 +331,7 @@ package body Par_SCO is ...@@ -328,9 +331,7 @@ package body Par_SCO is
function Is_Logical_Operator (N : Node_Id) return Boolean is function Is_Logical_Operator (N : Node_Id) return Boolean is
begin begin
return Nkind_In (N, N_Op_Not, return Nkind_In (N, N_Op_Not, N_And_Then, N_Or_Else);
N_And_Then,
N_Or_Else);
end Is_Logical_Operator; end Is_Logical_Operator;
----------------------- -----------------------
...@@ -475,7 +476,7 @@ package body Par_SCO is ...@@ -475,7 +476,7 @@ package body Par_SCO is
procedure Output_Header (T : Character) is procedure Output_Header (T : Character) is
Loc : Source_Ptr := No_Location; Loc : Source_Ptr := No_Location;
-- Node whose sloc is used for the decision -- Node whose Sloc is used for the decision
begin begin
case T is case T is
...@@ -488,13 +489,22 @@ package body Par_SCO is ...@@ -488,13 +489,22 @@ package body Par_SCO is
when 'G' | 'P' => when 'G' | 'P' =>
-- For entry, the token sloc is from the N_Entry_Body. For -- For entry guard, the token sloc is from the N_Entry_Body.
-- PRAGMA, we must get the location from the pragma node. -- For PRAGMA, we must get the location from the pragma node.
-- Argument N is the pragma argument, and we have to go up two -- Argument N is the pragma argument, and we have to go up two
-- levels (through the pragma argument association) to get to -- levels (through the pragma argument association) to get to
-- the pragma node itself. -- the pragma node itself. For the guard on a select
-- alternative, we do not have access to the token location
Loc := Sloc (Parent (Parent (N))); -- for the WHEN, so we use the sloc of the condition itself.
if Nkind_In (Parent (N), N_Accept_Alternative,
N_Delay_Alternative,
N_Terminate_Alternative)
then
Loc := Sloc (N);
else
Loc := Sloc (Parent (Parent (N)));
end if;
when 'X' => when 'X' =>
...@@ -547,10 +557,7 @@ package body Par_SCO is ...@@ -547,10 +557,7 @@ package body Par_SCO is
-- Logical operators, output table entries and then process -- Logical operators, output table entries and then process
-- operands recursively to deal with nested conditions. -- operands recursively to deal with nested conditions.
when N_And_Then | when N_And_Then | N_Or_Else | N_Op_Not =>
N_Or_Else |
N_Op_Not =>
declare declare
T : Character; T : Character;
...@@ -1036,7 +1043,8 @@ package body Par_SCO is ...@@ -1036,7 +1043,8 @@ package body Par_SCO is
procedure Traverse_Declarations_Or_Statements procedure Traverse_Declarations_Or_Statements
(L : List_Id; (L : List_Id;
D : Dominant_Info := No_Dominant) D : Dominant_Info := No_Dominant;
P : Node_Id := Empty)
is is
Current_Dominant : Dominant_Info := D; Current_Dominant : Dominant_Info := D;
-- Dominance information for the current basic block -- Dominance information for the current basic block
...@@ -1044,8 +1052,7 @@ package body Par_SCO is ...@@ -1044,8 +1052,7 @@ package body Par_SCO is
Current_Test : Node_Id; Current_Test : Node_Id;
-- Conditional node (N_If_Statement or N_Elsiif being processed -- Conditional node (N_If_Statement or N_Elsiif being processed
N : Node_Id; N : Node_Id;
Dummy : Source_Ptr;
SC_First : constant Nat := SC.Last + 1; SC_First : constant Nat := SC.Last + 1;
SD_First : constant Nat := SD.Last + 1; SD_First : constant Nat := SD.Last + 1;
...@@ -1056,15 +1063,6 @@ package body Par_SCO is ...@@ -1056,15 +1063,6 @@ package body Par_SCO is
-- is the letter that identifies the type of statement/declaration that -- is the letter that identifies the type of statement/declaration that
-- is being added to the sequence. -- is being added to the sequence.
procedure Extend_Statement_Sequence
(From : Node_Id;
To : Node_Id;
Typ : Character);
-- This version extends the current statement sequence with an entry
-- that starts with the first token of From, and ends with the last
-- token of To. It is used for example in a CASE statement to cover
-- the range from the CASE token to the last token of the expression.
procedure Set_Statement_Entry; procedure Set_Statement_Entry;
-- Output CS entries for all statements saved in table SC, and end the -- Output CS entries for all statements saved in table SC, and end the
-- current CS sequence. -- current CS sequence.
...@@ -1080,6 +1078,9 @@ package body Par_SCO is ...@@ -1080,6 +1078,9 @@ package body Par_SCO is
pragma Inline (Process_Decisions_Defer); pragma Inline (Process_Decisions_Defer);
-- Same case for list arguments, deferred call to Process_Decisions -- Same case for list arguments, deferred call to Process_Decisions
procedure Traverse_One (N : Node_Id);
-- Traverse one declaration or statement
------------------------- -------------------------
-- Set_Statement_Entry -- -- Set_Statement_Entry --
------------------------- -------------------------
...@@ -1180,24 +1181,50 @@ package body Par_SCO is ...@@ -1180,24 +1181,50 @@ package body Par_SCO is
------------------------------- -------------------------------
procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is
F : Source_Ptr; F : Source_Ptr;
T : Source_Ptr; T : Source_Ptr;
Dummy : Source_Ptr;
To_Node : Node_Id := Empty;
begin begin
Sloc_Range (N, F, T); Sloc_Range (N, F, T);
SC.Append ((N, F, T, Typ));
end Extend_Statement_Sequence;
procedure Extend_Statement_Sequence case Nkind (N) is
(From : Node_Id; when N_Accept_Statement =>
To : Node_Id; if Present (Parameter_Specifications (N)) then
Typ : Character) To_Node := Last (Parameter_Specifications (N));
is elsif Present (Entry_Index (N)) then
F : Source_Ptr; To_Node := Entry_Index (N);
T : Source_Ptr; end if;
begin
Sloc_Range (From, F, Dummy); when N_Case_Statement =>
Sloc_Range (To, Dummy, T); To_Node := Expression (N);
SC.Append ((From, F, T, Typ));
when N_If_Statement | N_Elsif_Part =>
To_Node := Condition (N);
when N_Extended_Return_Statement =>
To_Node := Last (Return_Object_Declarations (N));
when N_Loop_Statement =>
To_Node := Iteration_Scheme (N);
when N_Selective_Accept |
N_Timed_Entry_Call |
N_Conditional_Entry_Call |
N_Asynchronous_Select =>
T := F;
when others =>
null;
end case;
if Present (To_Node) then
Sloc_Range (To_Node, Dummy, T);
end if;
SC.Append ((N, F, T, Typ));
end Extend_Statement_Sequence; end Extend_Statement_Sequence;
----------------------------- -----------------------------
...@@ -1214,430 +1241,548 @@ package body Par_SCO is ...@@ -1214,430 +1241,548 @@ package body Par_SCO is
SD.Append ((Empty, L, T, Current_Pragma_Sloc)); SD.Append ((Empty, L, T, Current_Pragma_Sloc));
end Process_Decisions_Defer; end Process_Decisions_Defer;
-- Start of processing for Traverse_Declarations_Or_Statements ------------------
-- Traverse_One --
------------------
begin procedure Traverse_One (N : Node_Id) is
if Is_Non_Empty_List (L) then begin
-- Initialize or extend current statement sequence. Note that for
-- special cases such as IF and Case statements we will modify
-- the range to exclude internal statements that should not be
-- counted as part of the current statement sequence.
-- Loop through statements or declarations case Nkind (N) is
N := First (L); -- Package declaration
while Present (N) loop
-- Initialize or extend current statement sequence. Note that for when N_Package_Declaration =>
-- special cases such as IF and Case statements we will modify Set_Statement_Entry;
-- the range to exclude internal statements that should not be Traverse_Package_Declaration (N);
-- counted as part of the current statement sequence.
case Nkind (N) is -- Generic package declaration
-- Package declaration when N_Generic_Package_Declaration =>
Set_Statement_Entry;
Traverse_Generic_Package_Declaration (N);
when N_Package_Declaration => -- Package body
Set_Statement_Entry;
Traverse_Package_Declaration (N);
-- Generic package declaration when N_Package_Body =>
Set_Statement_Entry;
Traverse_Package_Body (N);
when N_Generic_Package_Declaration => -- Subprogram declaration
Set_Statement_Entry;
Traverse_Generic_Package_Declaration (N);
-- Package body when N_Subprogram_Declaration =>
Process_Decisions_Defer
(Parameter_Specifications (Specification (N)), 'X');
when N_Package_Body => -- Generic subprogram declaration
Set_Statement_Entry;
Traverse_Package_Body (N); when N_Generic_Subprogram_Declaration =>
Process_Decisions_Defer
(Generic_Formal_Declarations (N), 'X');
Process_Decisions_Defer
(Parameter_Specifications (Specification (N)), 'X');
-- Subprogram declaration -- Task or subprogram body
when N_Subprogram_Declaration => when N_Task_Body | N_Subprogram_Body =>
Process_Decisions_Defer Set_Statement_Entry;
(Parameter_Specifications (Specification (N)), 'X'); Traverse_Subprogram_Or_Task_Body (N);
-- Generic subprogram declaration -- Entry body
when N_Generic_Subprogram_Declaration => when N_Entry_Body =>
Process_Decisions_Defer declare
(Generic_Formal_Declarations (N), 'X'); Cond : constant Node_Id :=
Process_Decisions_Defer Condition (Entry_Body_Formal_Part (N));
(Parameter_Specifications (Specification (N)), 'X');
-- Task or subprogram body Inner_Dominant : Dominant_Info := No_Dominant;
when N_Task_Body | N_Subprogram_Body => begin
Set_Statement_Entry; Set_Statement_Entry;
Traverse_Subprogram_Or_Task_Body (N);
-- Entry body if Present (Cond) then
Process_Decisions_Defer (Cond, 'G');
-- For an entry body with a barrier, the entry body
-- is dominanted by a True evaluation of the barrier.
when N_Entry_Body => Inner_Dominant := ('T', N);
end if;
Traverse_Subprogram_Or_Task_Body (N, Inner_Dominant);
end;
-- Protected body
when N_Protected_Body =>
Set_Statement_Entry;
Traverse_Protected_Body (N);
-- Exit statement, which is an exit statement in the SCO sense,
-- so it is included in the current statement sequence, but
-- then it terminates this sequence. We also have to process
-- any decisions in the exit statement expression.
when N_Exit_Statement =>
Extend_Statement_Sequence (N, ' ');
Process_Decisions_Defer (Condition (N), 'E');
Set_Statement_Entry;
-- If condition is present, then following statement is
-- only executed if the condition evaluates to False.
if Present (Condition (N)) then
Current_Dominant := ('F', N);
else
Current_Dominant := No_Dominant;
end if;
-- Label, which breaks the current statement sequence, but the
-- label itself is not included in the next statement sequence,
-- since it generates no code.
when N_Label =>
Set_Statement_Entry;
Current_Dominant := No_Dominant;
-- Block statement, which breaks the current statement sequence
when N_Block_Statement =>
Set_Statement_Entry;
Traverse_Declarations_Or_Statements
(L => Declarations (N),
D => Current_Dominant);
Traverse_Handled_Statement_Sequence
(N => Handled_Statement_Sequence (N),
D => Current_Dominant);
-- If statement, which breaks the current statement sequence,
-- but we include the condition in the current sequence.
when N_If_Statement =>
Current_Test := N;
Extend_Statement_Sequence (N, 'I');
Process_Decisions_Defer (Condition (N), 'I');
Set_Statement_Entry;
-- Now we traverse the statements in the THEN part
Traverse_Declarations_Or_Statements
(L => Then_Statements (N),
D => ('T', N));
-- Loop through ELSIF parts if present
if Present (Elsif_Parts (N)) then
declare declare
Cond : constant Node_Id := Saved_Dominant : constant Dominant_Info :=
Condition (Entry_Body_Formal_Part (N)); Current_Dominant;
Inner_Dominant : Dominant_Info := No_Dominant;
begin
Set_Statement_Entry;
if Present (Cond) then Elif : Node_Id := First (Elsif_Parts (N));
Process_Decisions_Defer (Cond, 'G');
-- For an entry body with a barrier, the entry body begin
-- is dominanted by a True evaluation of the barrier. while Present (Elif) loop
Inner_Dominant := ('T', N); -- An Elsif is executed only if the previous test
end if; -- got a FALSE outcome.
Traverse_Subprogram_Or_Task_Body (N, Inner_Dominant); Current_Dominant := ('F', Current_Test);
end;
-- Protected body -- Now update current test information
when N_Protected_Body => Current_Test := Elif;
Set_Statement_Entry;
Traverse_Protected_Body (N);
-- Exit statement, which is an exit statement in the SCO sense, -- We generate a statement sequence for the
-- so it is included in the current statement sequence, but -- construct "ELSIF condition", so that we have
-- then it terminates this sequence. We also have to process -- a statement for the resulting decisions.
-- any decisions in the exit statement expression.
when N_Exit_Statement => Extend_Statement_Sequence (Elif, 'I');
Extend_Statement_Sequence (N, ' '); Process_Decisions_Defer (Condition (Elif), 'I');
Process_Decisions_Defer (Condition (N), 'E'); Set_Statement_Entry;
Set_Statement_Entry;
-- If condition is present, then following statement is -- An ELSIF part is never guaranteed to have
-- only executed if the condition evaluates to False. -- been executed, following statements are only
-- dominated by the initial IF statement.
if Present (Condition (N)) then Current_Dominant := Saved_Dominant;
Current_Dominant := ('F', N);
else
Current_Dominant := No_Dominant;
end if;
-- Label, which breaks the current statement sequence, but the -- Traverse the statements in the ELSIF
-- label itself is not included in the next statement sequence,
-- since it generates no code.
when N_Label => Traverse_Declarations_Or_Statements
Set_Statement_Entry; (L => Then_Statements (Elif),
Current_Dominant := No_Dominant; D => ('T', Elif));
Next (Elif);
end loop;
end;
end if;
-- Block statement, which breaks the current statement sequence -- Finally traverse the ELSE statements if present
when N_Block_Statement => Traverse_Declarations_Or_Statements
Set_Statement_Entry; (L => Else_Statements (N),
Traverse_Declarations_Or_Statements D => ('F', Current_Test));
(L => Declarations (N),
D => Current_Dominant);
Traverse_Handled_Statement_Sequence
(N => Handled_Statement_Sequence (N),
D => Current_Dominant);
-- If statement, which breaks the current statement sequence, -- CASE statement, which breaks the current statement sequence,
-- but we include the condition in the current sequence. -- but we include the expression in the current sequence.
when N_If_Statement => when N_Case_Statement =>
Current_Test := N; Extend_Statement_Sequence (N, 'C');
Extend_Statement_Sequence (N, Condition (N), 'I'); Process_Decisions_Defer (Expression (N), 'X');
Process_Decisions_Defer (Condition (N), 'I'); Set_Statement_Entry;
Set_Statement_Entry;
-- Now we traverse the statements in the THEN part -- Process case branches, all of which are dominated by the
-- CASE statement.
Traverse_Declarations_Or_Statements declare
(L => Then_Statements (N), Alt : Node_Id;
D => ('T', N)); begin
Alt := First (Alternatives (N));
while Present (Alt) loop
Traverse_Declarations_Or_Statements
(L => Statements (Alt),
D => Current_Dominant);
Next (Alt);
end loop;
end;
-- Loop through ELSIF parts if present -- ACCEPT statement
if Present (Elsif_Parts (N)) then when N_Accept_Statement =>
declare Extend_Statement_Sequence (N, 'A');
Saved_Dominant : constant Dominant_Info := Set_Statement_Entry;
Current_Dominant;
Elif : Node_Id := First (Elsif_Parts (N));
begin -- Process sequence of statements, dominant is the ACCEPT
while Present (Elif) loop -- statement.
-- An Elsif is executed only if the previous test Traverse_Handled_Statement_Sequence
-- got a FALSE outcome. (N => Handled_Statement_Sequence (N),
D => Current_Dominant);
Current_Dominant := ('F', Current_Test); -- SELECT
-- Now update current test information when N_Selective_Accept =>
Extend_Statement_Sequence (N, 'S');
Set_Statement_Entry;
Current_Test := Elif; -- Process alternatives
-- We generate a statement sequence for the declare
-- construct "ELSIF condition", so that we have Alt : Node_Id;
-- a statement for the resulting decisions. Guard : Node_Id;
S_Dom : Dominant_Info;
begin
Alt := First (Select_Alternatives (N));
while Present (Alt) loop
S_Dom := Current_Dominant;
Guard := Condition (Alt);
if Present (Guard) then
Process_Decisions
(Guard,
'G',
Pragma_Sloc => No_Location);
Current_Dominant := ('T', Guard);
end if;
Extend_Statement_Sequence Traverse_One (Alt);
(Elif, Condition (Elif), 'I');
Process_Decisions_Defer (Condition (Elif), 'I');
Set_Statement_Entry;
-- An ELSIF part is never guaranteed to have Current_Dominant := S_Dom;
-- been executed, following statements are only Next (Alt);
-- dominated by the initial IF statement. end loop;
end;
Current_Dominant := Saved_Dominant; Traverse_Declarations_Or_Statements
(L => Else_Statements (N),
D => Current_Dominant);
-- Traverse the statements in the ELSIF when N_Timed_Entry_Call | N_Conditional_Entry_Call =>
Extend_Statement_Sequence (N, 'S');
Set_Statement_Entry;
Traverse_Declarations_Or_Statements -- Process alternatives
(L => Then_Statements (Elif),
D => ('T', Elif));
Next (Elif);
end loop;
end;
end if;
-- Finally traverse the ELSE statements if present Traverse_One (Entry_Call_Alternative (N));
if Nkind (N) = N_Timed_Entry_Call then
Traverse_One (Delay_Alternative (N));
else
Traverse_Declarations_Or_Statements Traverse_Declarations_Or_Statements
(L => Else_Statements (N), (L => Else_Statements (N),
D => ('F', Current_Test)); D => Current_Dominant);
end if;
-- Case statement, which breaks the current statement sequence, when N_Asynchronous_Select =>
-- but we include the expression in the current sequence. Extend_Statement_Sequence (N, 'S');
Set_Statement_Entry;
when N_Case_Statement => Traverse_One (Triggering_Alternative (N));
Extend_Statement_Sequence (N, Expression (N), 'C'); Traverse_Declarations_Or_Statements
Process_Decisions_Defer (Expression (N), 'X'); (L => Statements (Abortable_Part (N)),
Set_Statement_Entry; D => Current_Dominant);
-- Process case branches, all of which are dominated by the when N_Accept_Alternative =>
-- CASE statement. Traverse_Declarations_Or_Statements
(L => Statements (N),
D => Current_Dominant,
P => Accept_Statement (N));
declare when N_Entry_Call_Alternative =>
Alt : Node_Id; Traverse_Declarations_Or_Statements
begin (L => Statements (N),
Alt := First (Alternatives (N)); D => Current_Dominant,
while Present (Alt) loop P => Entry_Call_Statement (N));
Traverse_Declarations_Or_Statements
(L => Statements (Alt), when N_Delay_Alternative =>
D => Current_Dominant); Traverse_Declarations_Or_Statements
Next (Alt); (L => Statements (N),
end loop; D => Current_Dominant,
end; P => Delay_Statement (N));
-- Unconditional exit points, which are included in the current when N_Triggering_Alternative =>
-- statement sequence, but then terminate it Traverse_Declarations_Or_Statements
(L => Statements (N),
D => Current_Dominant,
P => Triggering_Statement (N));
when N_Requeue_Statement | when N_Terminate_Alternative =>
N_Goto_Statement | Extend_Statement_Sequence (N, ' ');
N_Raise_Statement => Set_Statement_Entry;
Extend_Statement_Sequence (N, ' ');
Set_Statement_Entry;
Current_Dominant := No_Dominant;
-- Simple return statement. which is an exit point, but we -- Unconditional exit points, which are included in the current
-- have to process the return expression for decisions. -- statement sequence, but then terminate it
when N_Simple_Return_Statement => when N_Requeue_Statement |
Extend_Statement_Sequence (N, ' '); N_Goto_Statement |
Process_Decisions_Defer (Expression (N), 'X'); N_Raise_Statement =>
Set_Statement_Entry; Extend_Statement_Sequence (N, ' ');
Current_Dominant := No_Dominant; Set_Statement_Entry;
Current_Dominant := No_Dominant;
-- Extended return statement -- Simple return statement. which is an exit point, but we
-- have to process the return expression for decisions.
when N_Extended_Return_Statement => when N_Simple_Return_Statement =>
Extend_Statement_Sequence Extend_Statement_Sequence (N, ' ');
(N, Last (Return_Object_Declarations (N)), 'R'); Process_Decisions_Defer (Expression (N), 'X');
Process_Decisions_Defer Set_Statement_Entry;
(Return_Object_Declarations (N), 'X'); Current_Dominant := No_Dominant;
Set_Statement_Entry;
Traverse_Handled_Statement_Sequence -- Extended return statement
(N => Handled_Statement_Sequence (N),
D => Current_Dominant);
Current_Dominant := No_Dominant; when N_Extended_Return_Statement =>
Extend_Statement_Sequence (N, 'R');
Process_Decisions_Defer
(Return_Object_Declarations (N), 'X');
Set_Statement_Entry;
-- Loop ends the current statement sequence, but we include Traverse_Handled_Statement_Sequence
-- the iteration scheme if present in the current sequence. (N => Handled_Statement_Sequence (N),
-- But the body of the loop starts a new sequence, since it D => Current_Dominant);
-- may not be executed as part of the current sequence.
when N_Loop_Statement => Current_Dominant := No_Dominant;
declare
ISC : constant Node_Id := Iteration_Scheme (N);
Inner_Dominant : Dominant_Info := No_Dominant;
begin -- Loop ends the current statement sequence, but we include
if Present (ISC) then -- the iteration scheme if present in the current sequence.
-- But the body of the loop starts a new sequence, since it
-- may not be executed as part of the current sequence.
-- If iteration scheme present, extend the current when N_Loop_Statement =>
-- statement sequence to include the iteration scheme declare
-- and process any decisions it contains. ISC : constant Node_Id := Iteration_Scheme (N);
Inner_Dominant : Dominant_Info := No_Dominant;
-- While loop begin
if Present (ISC) then
if Present (Condition (ISC)) then -- If iteration scheme present, extend the current
Extend_Statement_Sequence (N, ISC, 'W'); -- statement sequence to include the iteration scheme
Process_Decisions_Defer (Condition (ISC), 'W'); -- and process any decisions it contains.
-- Set more specific dominant for inner statements -- While loop
-- (the control sloc for the decision is that of
-- the WHILE token).
Inner_Dominant := ('T', ISC); if Present (Condition (ISC)) then
Extend_Statement_Sequence (N, 'W');
Process_Decisions_Defer (Condition (ISC), 'W');
-- For loop -- Set more specific dominant for inner statements
-- (the control sloc for the decision is that of
-- the WHILE token).
else Inner_Dominant := ('T', ISC);
Extend_Statement_Sequence (N, ISC, 'F');
Process_Decisions_Defer
(Loop_Parameter_Specification (ISC), 'X');
end if;
end if;
Set_Statement_Entry; -- For loop
if Inner_Dominant = No_Dominant then else
Inner_Dominant := Current_Dominant; Extend_Statement_Sequence (N, 'F');
Process_Decisions_Defer
(Loop_Parameter_Specification (ISC), 'X');
end if; end if;
end if;
Traverse_Declarations_Or_Statements Set_Statement_Entry;
(L => Statements (N),
D => Inner_Dominant);
end;
-- Pragma if Inner_Dominant = No_Dominant then
Inner_Dominant := Current_Dominant;
end if;
when N_Pragma => Traverse_Declarations_Or_Statements
(L => Statements (N),
D => Inner_Dominant);
end;
-- Record sloc of pragma (pragmas don't nest) -- Pragma
pragma Assert (Current_Pragma_Sloc = No_Location); when N_Pragma =>
Current_Pragma_Sloc := Sloc (N);
-- Processing depends on the kind of pragma -- Record sloc of pragma (pragmas don't nest)
declare pragma Assert (Current_Pragma_Sloc = No_Location);
Nam : constant Name_Id := Pragma_Name (N); Current_Pragma_Sloc := Sloc (N);
Arg : Node_Id := First (Pragma_Argument_Associations (N));
Typ : Character;
begin -- Processing depends on the kind of pragma
case Nam is
when Name_Assert |
Name_Check |
Name_Precondition |
Name_Postcondition =>
-- For Assert/Check/Precondition/Postcondition, we
-- must generate a P entry for the decision. Note
-- that this is done unconditionally at this stage.
-- Output for disabled pragmas is suppressed later
-- on when we output the decision line in Put_SCOs,
-- depending on setting by Set_SCO_Pragma_Enabled.
if Nam = Name_Check then
Next (Arg);
end if;
Process_Decisions_Defer (Expression (Arg), 'P'); declare
Typ := 'p'; Nam : constant Name_Id := Pragma_Name (N);
Arg : Node_Id :=
First (Pragma_Argument_Associations (N));
Typ : Character;
when Name_Debug => begin
if Present (Arg) and then Present (Next (Arg)) then case Nam is
when Name_Assert |
Name_Check |
Name_Precondition |
Name_Postcondition =>
-- For Assert/Check/Precondition/Postcondition, we
-- must generate a P entry for the decision. Note
-- that this is done unconditionally at this stage.
-- Output for disabled pragmas is suppressed later
-- on when we output the decision line in Put_SCOs,
-- depending on setting by Set_SCO_Pragma_Enabled.
if Nam = Name_Check then
Next (Arg);
end if;
-- Case of a dyadic pragma Debug: first argument Process_Decisions_Defer (Expression (Arg), 'P');
-- is a P decision, any nested decision in the Typ := 'p';
-- second argument is an X decision.
Process_Decisions_Defer (Expression (Arg), 'P'); when Name_Debug =>
Next (Arg); if Present (Arg) and then Present (Next (Arg)) then
end if;
Process_Decisions_Defer (Expression (Arg), 'X'); -- Case of a dyadic pragma Debug: first argument
Typ := 'p'; -- is a P decision, any nested decision in the
-- second argument is an X decision.
-- For all other pragmas, we generate decision entries Process_Decisions_Defer (Expression (Arg), 'P');
-- for any embedded expressions, and the pragma is Next (Arg);
-- never disabled. end if;
when others => Process_Decisions_Defer (Expression (Arg), 'X');
Process_Decisions_Defer (N, 'X'); Typ := 'p';
Typ := 'P';
end case;
-- Add statement SCO -- For all other pragmas, we generate decision entries
-- for any embedded expressions, and the pragma is
-- never disabled.
Extend_Statement_Sequence (N, Typ); when others =>
Process_Decisions_Defer (N, 'X');
Typ := 'P';
end case;
Current_Pragma_Sloc := No_Location; -- Add statement SCO
end;
-- Object declaration. Ignored if Prev_Ids is set, since the Extend_Statement_Sequence (N, Typ);
-- parser generates multiple instances of the whole declaration
-- if there is more than one identifier declared, and we only
-- want one entry in the SCO's, so we take the first, for which
-- Prev_Ids is False.
when N_Object_Declaration => Current_Pragma_Sloc := No_Location;
if not Prev_Ids (N) then end;
Extend_Statement_Sequence (N, 'o');
if Has_Decision (N) then -- Object declaration. Ignored if Prev_Ids is set, since the
Process_Decisions_Defer (N, 'X'); -- parser generates multiple instances of the whole declaration
end if; -- if there is more than one identifier declared, and we only
end if; -- want one entry in the SCO's, so we take the first, for which
-- Prev_Ids is False.
-- All other cases, which extend the current statement sequence when N_Object_Declaration =>
-- but do not terminate it, even if they have nested decisions. if not Prev_Ids (N) then
Extend_Statement_Sequence (N, 'o');
when others => if Has_Decision (N) then
Process_Decisions_Defer (N, 'X');
end if;
end if;
-- Determine required type character code, or ASCII.NUL if -- All other cases, which extend the current statement sequence
-- no SCO should be generated for this node. -- but do not terminate it, even if they have nested decisions.
declare when others =>
Typ : Character;
begin -- Determine required type character code, or ASCII.NUL if
case Nkind (N) is -- no SCO should be generated for this node.
when N_Full_Type_Declaration |
N_Incomplete_Type_Declaration |
N_Private_Type_Declaration |
N_Private_Extension_Declaration =>
Typ := 't';
when N_Subtype_Declaration => declare
Typ := 's'; Typ : Character;
when N_Renaming_Declaration => begin
Typ := 'r'; case Nkind (N) is
when N_Full_Type_Declaration |
N_Incomplete_Type_Declaration |
N_Private_Type_Declaration |
N_Private_Extension_Declaration =>
Typ := 't';
when N_Generic_Instantiation => when N_Subtype_Declaration =>
Typ := 'i'; Typ := 's';
when N_Representation_Clause | when N_Renaming_Declaration =>
N_Use_Package_Clause | Typ := 'r';
N_Use_Type_Clause =>
Typ := ASCII.NUL;
when others => when N_Generic_Instantiation =>
Typ := ' '; Typ := 'i';
end case;
if Typ /= ASCII.NUL then when N_Representation_Clause |
Extend_Statement_Sequence (N, Typ); N_Use_Package_Clause |
end if; N_Use_Type_Clause =>
end; Typ := ASCII.NUL;
-- Process any embedded decisions when others =>
Typ := ' ';
end case;
if Has_Decision (N) then if Typ /= ASCII.NUL then
Process_Decisions_Defer (N, 'X'); Extend_Statement_Sequence (N, Typ);
end if; end if;
end case; end;
-- Process any embedded decisions
if Has_Decision (N) then
Process_Decisions_Defer (N, 'X');
end if;
end case;
end Traverse_One;
-- Start of processing for Traverse_Declarations_Or_Statements
begin
if Present (P) then
Traverse_One (P);
end if;
if Is_Non_Empty_List (L) then
-- Loop through statements or declarations
N := First (L);
while Present (N) loop
Traverse_One (N);
Next (N); Next (N);
end loop; end loop;
......
gcc/ada/restrict.adb
...@@ -541,10 +541,10 @@ package body Restrict is ...@@ -541,10 +541,10 @@ package body Restrict is
then then
null; null;
-- Here if restriction set, check for violation (either this is a -- Here if restriction set, check for violation (this is a Boolean
-- Boolean restriction, or a parameter restriction with a value of -- restriction, or a parameter restriction with a value of zero and an
-- zero and an unknown count, or a parameter restriction with a -- unknown count, or a parameter restriction with a known value that
-- known value that exceeds the restriction count). -- exceeds the restriction count).
elsif R in All_Boolean_Restrictions elsif R in All_Boolean_Restrictions
or else (Restrictions.Unknown (R) or else (Restrictions.Unknown (R)
...@@ -768,7 +768,7 @@ package body Restrict is ...@@ -768,7 +768,7 @@ package body Restrict is
---------------------------------- ----------------------------------
-- Note: body of this function must be coordinated with list of -- Note: body of this function must be coordinated with list of
-- renaming declarations in Rident. -- renaming declarations in System.Rident.
function Process_Restriction_Synonyms (N : Node_Id) return Name_Id function Process_Restriction_Synonyms (N : Node_Id) return Name_Id
is is
......
gcc/ada/restrict.ads
...@@ -332,10 +332,10 @@ package Restrict is ...@@ -332,10 +332,10 @@ package Restrict is
-- exception propagation is activated. -- exception propagation is activated.
function Process_Restriction_Synonyms (N : Node_Id) return Name_Id; function Process_Restriction_Synonyms (N : Node_Id) return Name_Id;
-- Id is a node whose Chars field contains the name of a restriction. If it -- Id is a node whose Chars field contains the name of a restriction.
-- is one of synonyms that we allow for historical purposes (for list see -- If it is one of synonyms that we allow for historical purposes (for
-- Rident), then the proper official name is returned. Otherwise the Chars -- list see System.Rident), then the proper official name is returned.
-- field of the argument is returned unchanged. -- Otherwise the Chars field of the argument is returned unchanged.
function Restriction_Active (R : All_Restrictions) return Boolean; function Restriction_Active (R : All_Restrictions) return Boolean;
pragma Inline (Restriction_Active); pragma Inline (Restriction_Active);
......
gcc/ada/rident.ads
...@@ -34,416 +34,16 @@ ...@@ -34,416 +34,16 @@
-- it can be used by the binder without dragging in unneeded compiler -- it can be used by the binder without dragging in unneeded compiler
-- packages. -- packages.
package Rident is -- Note: the actual definitions of the types are in package System.Rident,
-- and this package is merely an instantiation of that package. The point
-- of this level of generic indirection is to allow the compile time use
-- to have the image tables available (this package is not compiled with
-- Discard_Names), while at run-time we do not want those image tables.
-- The following enumeration type defines the set of restriction -- Rather than have clients instantiate System.Rident directly, we have the
-- identifiers that are implemented in GNAT. -- single instantiation here at the library level, which means that we only
-- have one copy of the image tables
-- To add a new restriction identifier, add an entry with the name to be with System.Rident;
-- used in the pragma, and add calls to the Restrict.Check_Restriction
-- routine as appropriate.
type Restriction_Id is package Rident is new System.Rident;
-- The following cases are checked for consistency in the binder. The
-- binder will check that every unit either has the restriction set, or
-- does not violate the restriction.
(Simple_Barriers, -- GNAT (Ravenscar)
No_Abort_Statements, -- (RM D.7(5), H.4(3))
No_Access_Subprograms, -- (RM H.4(17))
No_Allocators, -- (RM H.4(7))
No_Allocators_After_Elaboration, -- Ada 2012 (RM D.7(19.1/2))
No_Anonymous_Allocators, -- Ada 2012 (RM H.4(8/1))
No_Asynchronous_Control, -- (RM D.7(10))
No_Calendar, -- GNAT
No_Default_Stream_Attributes, -- Ada 2012 (RM 13.12.1(4/2))
No_Delay, -- (RM H.4(21))
No_Direct_Boolean_Operators, -- GNAT
No_Dispatch, -- (RM H.4(19))
No_Dispatching_Calls, -- GNAT
No_Dynamic_Attachment, -- GNAT
No_Dynamic_Priorities, -- (RM D.9(9))
No_Enumeration_Maps, -- GNAT
No_Entry_Calls_In_Elaboration_Code, -- GNAT
No_Entry_Queue, -- GNAT (Ravenscar)
No_Exception_Handlers, -- GNAT
No_Exception_Propagation, -- GNAT
No_Exception_Registration, -- GNAT
No_Exceptions, -- (RM H.4(12))
No_Finalization, -- GNAT
No_Fixed_Point, -- (RM H.4(15))
No_Floating_Point, -- (RM H.4(14))
No_IO, -- (RM H.4(20))
No_Implicit_Conditionals, -- GNAT
No_Implicit_Dynamic_Code, -- GNAT
No_Implicit_Heap_Allocations, -- (RM D.8(8), H.4(3))
No_Implicit_Loops, -- GNAT
No_Initialize_Scalars, -- GNAT
No_Local_Allocators, -- (RM H.4(8))
No_Local_Timing_Events, -- (RM D.7(10.2/2))
No_Local_Protected_Objects, -- GNAT
No_Nested_Finalization, -- (RM D.7(4))
No_Protected_Type_Allocators, -- GNAT
No_Protected_Types, -- (RM H.4(5))
No_Recursion, -- (RM H.4(22))
No_Reentrancy, -- (RM H.4(23))
No_Relative_Delay, -- GNAT (Ravenscar)
No_Requeue_Statements, -- GNAT
No_Secondary_Stack, -- GNAT
No_Select_Statements, -- GNAT (Ravenscar)
No_Specific_Termination_Handlers, -- (RM D.7(10.7/2))
No_Standard_Storage_Pools, -- GNAT
No_Stream_Optimizations, -- GNAT
No_Streams, -- GNAT
No_Task_Allocators, -- (RM D.7(7))
No_Task_Attributes_Package, -- GNAT
No_Task_Hierarchy, -- (RM D.7(3), H.4(3))
No_Task_Termination, -- GNAT (Ravenscar)
No_Tasking, -- GNAT
No_Terminate_Alternatives, -- (RM D.7(6))
No_Unchecked_Access, -- (RM H.4(18))
No_Unchecked_Conversion, -- (RM H.4(16))
No_Unchecked_Deallocation, -- (RM H.4(9))
Static_Priorities, -- GNAT
Static_Storage_Size, -- GNAT
-- The following require consistency checking with special rules. See
-- individual routines in unit Bcheck for details of what is required.
No_Default_Initialization, -- GNAT
-- The following cases do not require consistency checking and if used
-- as a configuration pragma within a specific unit, apply only to that
-- unit (e.g. if used in the package spec, do not apply to the body)
-- Note: No_Elaboration_Code is handled specially. Like the other
-- non-partition-wide restrictions, it can only be set in a unit that
-- is part of the extended main source unit (body/spec/subunits). But
-- it is sticky, in that if it is found anywhere within any of these
-- units, it applies to all units in this extended main source.
Immediate_Reclamation, -- (RM H.4(10))
No_Implementation_Aspect_Specifications, -- Ada 2012 AI-241
No_Implementation_Attributes, -- Ada 2005 AI-257
No_Implementation_Identifiers, -- Ada 2012 AI-246
No_Implementation_Pragmas, -- Ada 2005 AI-257
No_Implementation_Restrictions, -- GNAT
No_Implementation_Units, -- Ada 2012 AI-242
No_Implicit_Aliasing, -- GNAT
No_Elaboration_Code, -- GNAT
No_Obsolescent_Features, -- Ada 2005 AI-368
No_Wide_Characters, -- GNAT
SPARK, -- GNAT
-- The following cases require a parameter value
-- The following entries are fully checked at compile/bind time, which
-- means that the compiler can in general tell the minimum value which
-- could be used with a restrictions pragma. The binder can deduce the
-- appropriate minimum value for the partition by taking the maximum
-- value required by any unit.
Max_Protected_Entries, -- (RM D.7(14))
Max_Select_Alternatives, -- (RM D.7(12))
Max_Task_Entries, -- (RM D.7(13), H.4(3))
-- The following entries are also fully checked at compile/bind time,
-- and the compiler can also at least in some cases tell the minimum
-- value which could be used with a restriction pragma. The difference
-- is that the contributions are additive, so the binder deduces this
-- value by adding the unit contributions.
Max_Tasks, -- (RM D.7(19), H.4(3))
-- The following entries are checked at compile time only for zero/
-- nonzero entries. This means that the compiler can tell at compile
-- time if a restriction value of zero is (would be) violated, but that
-- the compiler cannot distinguish between different non-zero values.
Max_Asynchronous_Select_Nesting, -- (RM D.7(18), H.4(3))
Max_Entry_Queue_Length, -- GNAT
-- The remaining entries are not checked at compile/bind time
Max_Storage_At_Blocking, -- (RM D.7(17))
Not_A_Restriction_Id);
-- Synonyms permitted for historical purposes of compatibility.
-- Must be coordinated with Restrict.Process_Restriction_Synonym.
Boolean_Entry_Barriers : Restriction_Id renames Simple_Barriers;
Max_Entry_Queue_Depth : Restriction_Id renames Max_Entry_Queue_Length;
No_Dynamic_Interrupts : Restriction_Id renames No_Dynamic_Attachment;
No_Requeue : Restriction_Id renames No_Requeue_Statements;
No_Task_Attributes : Restriction_Id renames No_Task_Attributes_Package;
subtype All_Restrictions is Restriction_Id range
Simple_Barriers .. Max_Storage_At_Blocking;
-- All restrictions (excluding only Not_A_Restriction_Id)
subtype All_Boolean_Restrictions is Restriction_Id range
Simple_Barriers .. SPARK;
-- All restrictions which do not take a parameter
subtype Partition_Boolean_Restrictions is All_Boolean_Restrictions range
Simple_Barriers .. Static_Storage_Size;
-- Boolean restrictions that are checked for partition consistency.
-- Note that all parameter restrictions are checked for partition
-- consistency by default, so this distinction is only needed in the
-- case of Boolean restrictions.
subtype Cunit_Boolean_Restrictions is All_Boolean_Restrictions range
Immediate_Reclamation .. SPARK;
-- Boolean restrictions that are not checked for partition consistency
-- and that thus apply only to the current unit. Note that for these
-- restrictions, the compiler does not apply restrictions found in
-- with'ed units, parent specs etc. to the main unit, and vice versa.
subtype All_Parameter_Restrictions is
Restriction_Id range
Max_Protected_Entries .. Max_Storage_At_Blocking;
-- All restrictions that take a parameter
subtype Checked_Parameter_Restrictions is
All_Parameter_Restrictions range
Max_Protected_Entries .. Max_Entry_Queue_Length;
-- These are the parameter restrictions that can be at least partially
-- checked at compile/binder time. Minimally, the compiler can detect
-- violations of a restriction pragma with a value of zero reliably.
subtype Checked_Max_Parameter_Restrictions is
Checked_Parameter_Restrictions range
Max_Protected_Entries .. Max_Task_Entries;
-- Restrictions with parameters that can be checked in some cases by
-- maximizing among statically detected instances where the compiler
-- can determine the count.
subtype Checked_Add_Parameter_Restrictions is
Checked_Parameter_Restrictions range
Max_Tasks .. Max_Tasks;
-- Restrictions with parameters that can be checked in some cases by
-- summing the statically detected instances where the compiler can
-- determine the count.
subtype Checked_Val_Parameter_Restrictions is
Checked_Parameter_Restrictions range
Max_Protected_Entries .. Max_Tasks;
-- Restrictions with parameter where the count is known at least in some
-- cases by the compiler/binder.
subtype Checked_Zero_Parameter_Restrictions is
Checked_Parameter_Restrictions range
Max_Asynchronous_Select_Nesting .. Max_Entry_Queue_Length;
-- Restrictions with parameters where the compiler can detect the use of
-- the feature, and hence violations of a restriction specifying a value
-- of zero, but cannot detect specific values other than zero/nonzero.
subtype Unchecked_Parameter_Restrictions is
All_Parameter_Restrictions range
Max_Storage_At_Blocking .. Max_Storage_At_Blocking;
-- Restrictions with parameters where the compiler cannot ever detect
-- corresponding compile time usage, so the binder and compiler never
-- detect violations of any restriction.
-------------------------------------
-- Restriction Status Declarations --
-------------------------------------
-- The following declarations are used to record the current status or
-- restrictions (for the current unit, or related units, at compile time,
-- and for all units in a partition at bind time or run time).
type Restriction_Flags is array (All_Restrictions) of Boolean;
type Restriction_Values is array (All_Parameter_Restrictions) of Natural;
type Parameter_Flags is array (All_Parameter_Restrictions) of Boolean;
type Restrictions_Info is record
Set : Restriction_Flags;
-- An entry is True in the Set array if a restrictions pragma has been
-- encountered for the given restriction. If the value is True for a
-- parameter restriction, then the corresponding entry in the Value
-- array gives the minimum value encountered for any such restriction.
Value : Restriction_Values;
-- If the entry for a parameter restriction in Set is True (i.e. a
-- restrictions pragma for the restriction has been encountered), then
-- the corresponding entry in the Value array is the minimum value
-- specified by any such restrictions pragma. Note that a restrictions
-- pragma specifying a value greater than Int'Last is simply ignored.
Violated : Restriction_Flags;
-- An entry is True in the violations array if the compiler has detected
-- a violation of the restriction. For a parameter restriction, the
-- Count and Unknown arrays have additional information.
Count : Restriction_Values;
-- If an entry for a parameter restriction is True in Violated, the
-- corresponding entry in the Count array may record additional
-- information. If the actual minimum count is known (by taking
-- maximums, or sums, depending on the restriction), it will be
-- recorded in this array. If not, then the value will remain zero.
-- The value is also zero for a non-violated restriction.
Unknown : Parameter_Flags;
-- If an entry for a parameter restriction is True in Violated, the
-- corresponding entry in the Unknown array may record additional
-- information. If the actual count is not known by the compiler (but
-- is known to be non-zero), then the entry in Unknown will be True.
-- This indicates that the value in Count is not known to be exact,
-- and the actual violation count may be higher.
-- Note: If Violated (K) is True, then either Count (K) > 0 or
-- Unknown (K) = True. It is possible for both these to be set.
-- For example, if Count (K) = 3 and Unknown (K) is True, it means
-- that the actual violation count is at least 3 but might be higher.
end record;
No_Restrictions : constant Restrictions_Info :=
(Set => (others => False),
Value => (others => 0),
Violated => (others => False),
Count => (others => 0),
Unknown => (others => False));
-- Used to initialize Restrictions_Info variables
----------------------------------
-- Profile Definitions and Data --
----------------------------------
-- Note: to add a profile, modify the following declarations appropriately,
-- add Name_xxx to Snames, and add a branch to the conditions for pragmas
-- Profile and Profile_Warnings in the body of Sem_Prag.
type Profile_Name is
(No_Profile,
No_Implementation_Extensions,
Ravenscar,
Restricted);
-- Names of recognized profiles. No_Profile is used to indicate that a
-- restriction came from pragma Restrictions[_Warning], as opposed to
-- pragma Profile[_Warning].
subtype Profile_Name_Actual is Profile_Name
range No_Implementation_Extensions .. Restricted;
-- Actual used profile names
type Profile_Data is record
Set : Restriction_Flags;
-- Set to True if given restriction must be set for the profile, and
-- False if it need not be set (False does not mean that it must not be
-- set, just that it need not be set). If the flag is True for a
-- parameter restriction, then the Value array gives the maximum value
-- permitted by the profile.
Value : Restriction_Values;
-- An entry in this array is meaningful only if the corresponding flag
-- in Set is True. In that case, the value in this array is the maximum
-- value of the parameter permitted by the profile.
end record;
Profile_Info : constant array (Profile_Name_Actual) of Profile_Data :=
(No_Implementation_Extensions =>
-- Restrictions for Restricted profile
(Set =>
(No_Implementation_Aspect_Specifications => True,
No_Implementation_Attributes => True,
No_Implementation_Identifiers => True,
No_Implementation_Pragmas => True,
No_Implementation_Units => True,
others => False),
-- Value settings for Restricted profile (none
Value =>
(others => 0)),
-- Restricted Profile
Restricted =>
-- Restrictions for Restricted profile
(Set =>
(No_Abort_Statements => True,
No_Asynchronous_Control => True,
No_Dynamic_Attachment => True,
No_Dynamic_Priorities => True,
No_Entry_Queue => True,
No_Local_Protected_Objects => True,
No_Protected_Type_Allocators => True,
No_Requeue_Statements => True,
No_Task_Allocators => True,
No_Task_Attributes_Package => True,
No_Task_Hierarchy => True,
No_Terminate_Alternatives => True,
Max_Asynchronous_Select_Nesting => True,
Max_Protected_Entries => True,
Max_Select_Alternatives => True,
Max_Task_Entries => True,
others => False),
-- Value settings for Restricted profile
Value =>
(Max_Asynchronous_Select_Nesting => 0,
Max_Protected_Entries => 1,
Max_Select_Alternatives => 0,
Max_Task_Entries => 0,
others => 0)),
-- Ravenscar Profile
-- Note: the table entries here only represent the
-- required restriction profile for Ravenscar. The
-- full Ravenscar profile also requires:
-- pragma Dispatching_Policy (FIFO_Within_Priorities);
-- pragma Locking_Policy (Ceiling_Locking);
-- pragma Detect_Blocking
Ravenscar =>
-- Restrictions for Ravenscar = Restricted profile ..
(Set =>
(No_Abort_Statements => True,
No_Asynchronous_Control => True,
No_Dynamic_Attachment => True,
No_Dynamic_Priorities => True,
No_Entry_Queue => True,
No_Local_Protected_Objects => True,
No_Protected_Type_Allocators => True,
No_Requeue_Statements => True,
No_Task_Allocators => True,
No_Task_Attributes_Package => True,
No_Task_Hierarchy => True,
No_Terminate_Alternatives => True,
Max_Asynchronous_Select_Nesting => True,
Max_Protected_Entries => True,
Max_Select_Alternatives => True,
Max_Task_Entries => True,
-- plus these additional restrictions:
No_Calendar => True,
No_Implicit_Heap_Allocations => True,
No_Relative_Delay => True,
No_Select_Statements => True,
No_Task_Termination => True,
Simple_Barriers => True,
others => False),
-- Value settings for Ravenscar (same as Restricted)
Value =>
(Max_Asynchronous_Select_Nesting => 0,
Max_Protected_Entries => 1,
Max_Select_Alternatives => 0,
Max_Task_Entries => 0,
others => 0)));
end Rident;
gcc/ada/s-atopri.adb
...@@ -30,14 +30,15 @@ ...@@ -30,14 +30,15 @@
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
package body System.Atomic_Primitives is package body System.Atomic_Primitives is
--------------------------- ---------------------------
-- Lock_Free_Try_Write_8 -- -- Lock_Free_Try_Write_8 --
--------------------------- ---------------------------
function Lock_Free_Try_Write_8 function Lock_Free_Try_Write_8
(Ptr : Address; (Ptr : Address;
Expected : in out uint8; Expected : in out uint8;
Desired : uint8) return Boolean Desired : uint8) return Boolean
is is
Actual : uint8; Actual : uint8;
...@@ -59,9 +60,9 @@ package body System.Atomic_Primitives is ...@@ -59,9 +60,9 @@ package body System.Atomic_Primitives is
---------------------------- ----------------------------
function Lock_Free_Try_Write_16 function Lock_Free_Try_Write_16
(Ptr : Address; (Ptr : Address;
Expected : in out uint16; Expected : in out uint16;
Desired : uint16) return Boolean Desired : uint16) return Boolean
is is
Actual : uint16; Actual : uint16;
...@@ -83,9 +84,9 @@ package body System.Atomic_Primitives is ...@@ -83,9 +84,9 @@ package body System.Atomic_Primitives is
---------------------------- ----------------------------
function Lock_Free_Try_Write_32 function Lock_Free_Try_Write_32
(Ptr : Address; (Ptr : Address;
Expected : in out uint32; Expected : in out uint32;
Desired : uint32) return Boolean Desired : uint32) return Boolean
is is
Actual : uint32; Actual : uint32;
...@@ -107,9 +108,9 @@ package body System.Atomic_Primitives is ...@@ -107,9 +108,9 @@ package body System.Atomic_Primitives is
---------------------------- ----------------------------
function Lock_Free_Try_Write_64 function Lock_Free_Try_Write_64
(Ptr : Address; (Ptr : Address;
Expected : in out uint64; Expected : in out uint64;
Desired : uint64) return Boolean Desired : uint64) return Boolean
is is
Actual : uint64; Actual : uint64;
......
gcc/ada/s-atopri.ads
...@@ -152,24 +152,24 @@ package System.Atomic_Primitives is ...@@ -152,24 +152,24 @@ package System.Atomic_Primitives is
(Atomic_Load_64 (Ptr, Acquire)); (Atomic_Load_64 (Ptr, Acquire));
function Lock_Free_Try_Write_8 function Lock_Free_Try_Write_8
(Ptr : Address; (Ptr : Address;
Expected : in out uint8; Expected : in out uint8;
Desired : uint8) return Boolean; Desired : uint8) return Boolean;
function Lock_Free_Try_Write_16 function Lock_Free_Try_Write_16
(Ptr : Address; (Ptr : Address;
Expected : in out uint16; Expected : in out uint16;
Desired : uint16) return Boolean; Desired : uint16) return Boolean;
function Lock_Free_Try_Write_32 function Lock_Free_Try_Write_32
(Ptr : Address; (Ptr : Address;
Expected : in out uint32; Expected : in out uint32;
Desired : uint32) return Boolean; Desired : uint32) return Boolean;
function Lock_Free_Try_Write_64 function Lock_Free_Try_Write_64
(Ptr : Address; (Ptr : Address;
Expected : in out uint64; Expected : in out uint64;
Desired : uint64) return Boolean; Desired : uint64) return Boolean;
pragma Inline (Lock_Free_Read_8); pragma Inline (Lock_Free_Read_8);
pragma Inline (Lock_Free_Read_16); pragma Inline (Lock_Free_Read_16);
......
gcc/ada/s-rident.ads
...@@ -30,17 +30,44 @@ ...@@ -30,17 +30,44 @@
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This package defines the set of restriction identifiers. It is a generic -- This package defines the set of restriction identifiers. It is a generic
-- package that is instantiated by the binder for output of the restrictions -- package that is instantiated by the compiler/binder in package Rident, and
-- structure, and is instantiated in package System.Restrictions for use at -- is instantiated in package System.Restrictions for use at run-time.
-- run-time.
-- The reason that we make this a generic package is so that in the case of -- The reason that we make this a generic package is so that in the case of
-- the instantiation in the binder, we can generate normal image tables for -- the instantiation in Rident for use at compile time and bind time, we can
-- the enumeration types, which are needed for diagnostic and informational -- generate normal image tables for the enumeration types, which are needed
-- messages as well as for identification of restrictions. At run-time we -- for diagnostic and informational messages. At run-time we really do not
-- really do not want to waste the space for these image tables, and they are -- want to waste the space for these image tables, and they are not needed,
-- not needed, so we can do the instantiation under control of Discard_Names -- so we can do the instantiation under control of Discard_Names to remove
-- to remove the tables. -- the tables.
---------------------------------------------------
-- Note On Compile/Run-Time Consistency Checking --
---------------------------------------------------
-- This unit is with'ed by the run-time (to make System.Restrictions which is
-- used for run-time access to restriction information), by the compiler (to
-- determine what restrictions are implemented and what their category is) and
-- by the binder (in processing ali files, and generating the information used
-- at run-time to access restriction information).
-- Normally the version of System.Rident referenced in all three contexts
-- should be the same. However, problems could arise in certain inconsistent
-- builds that used inconsistent versions of the compiler and run-time. This
-- sort of thing is not strictly correct, but it does arise when short-cuts
-- are taken in build procedures.
-- Previously, this kind of inconsistency could cause a significant problem.
-- If versions of System.Rident accessed by the compiler and binder differed,
-- then the binder could fail to recognize the R (restrictions line) in the
-- ali file, leading to bind errors when restrictions were added or removed.
-- The latest implementation avoids both this problem by using a named
-- scheme for recording restrictions, rather than a positional scheme which
-- fails completely if restrictions are added or subtracted. Now the worst
-- that happens at bind time in incosistent builds is that unrecognized
-- restrictions are ignored, and the consistency checking for restrictions
-- might be incomplete, which is no big deal.
pragma Compiler_Unit; pragma Compiler_Unit;
......
gcc/ada/scos.ads
...@@ -152,14 +152,16 @@ package SCOs is ...@@ -152,14 +152,16 @@ package SCOs is
-- o object declaration -- o object declaration
-- r renaming declaration -- r renaming declaration
-- i generic instantiation -- i generic instantiation
-- C CASE statement (from CASE through end of expression) -- A ACCEPT statement (from ACCEPT to end of parameter profile)
-- C CASE statement (from CASE to end of expression)
-- E EXIT statement -- E EXIT statement
-- F FOR loop (from FOR through end of iteration scheme) -- F FOR loop (from FOR to end of iteration scheme)
-- I IF statement (from IF through end of condition) -- I IF statement (from IF to end of condition)
-- P[name:] PRAGMA with the indicated name -- P[name:] PRAGMA with the indicated name
-- p[name:] disabled PRAGMA with the indicated name -- p[name:] disabled PRAGMA with the indicated name
-- R extended RETURN statement -- R extended RETURN statement
-- W WHILE loop statement (from WHILE through end of condition) -- S SELECT statement
-- W WHILE loop statement (from WHILE to end of condition)
-- Note: for I and W, condition above is in the RM syntax sense (this -- Note: for I and W, condition above is in the RM syntax sense (this
-- condition is a decision in SCO terminology). -- condition is a decision in SCO terminology).
......
gcc/ada/sem_prag.adb
...@@ -6254,7 +6254,7 @@ package body Sem_Prag is ...@@ -6254,7 +6254,7 @@ package body Sem_Prag is
-- Set Detect_Blocking mode -- Set Detect_Blocking mode
-- Set required restrictions (see Rident for detailed list) -- Set required restrictions (see System.Rident for detailed list)
-- Set the No_Dependence rules -- Set the No_Dependence rules
-- No_Dependence => Ada.Asynchronous_Task_Control -- No_Dependence => Ada.Asynchronous_Task_Control
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment