+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
Ignore_Errors : Boolean := False;
Directly_Scanned : Boolean := False) return ALI_Id
is
- P : Text_Ptr := T'First;
+ P : Text_Ptr := T'First;
Line : Logical_Line_Number := 1;
Id : ALI_Id;
C : Character;
C := Getc;
Check_Unknown_Line;
- -- Acquire first restrictions line
+ -- Loop to skip to first restrictions line
while C /= 'R' loop
if Ignore_Errors then
end if;
end loop;
+ -- Ignore all 'R' lines if that is required
+
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
Scan_Restrictions : declare
Bad_R_Line : exception;
-- Signal bad restrictions line (raised on unexpected character)
- begin
- Checkc (' ');
- Skip_Space;
+ Typ : Character;
+ R : Restriction_Id;
+ 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;
- 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' =>
ALIs.Table (Id).Restrictions.Violated (R) := True;
Cumulative_Restrictions.Violated (R) := True;
when others =>
raise Bad_R_Line;
- end case;
- end loop;
-
- -- Acquire information for parameter restrictions
+ end case;
+ end loop;
- 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 'n' =>
- null;
+ when 'r' =>
+ ALIs.Table (Id).Restrictions.Set (RP) := True;
- when 'r' =>
- ALIs.Table (Id).Restrictions.Set (RP) := True;
+ declare
+ N : constant Integer := Integer (Get_Nat);
+ begin
+ ALIs.Table (Id).Restrictions.Value (RP) := N;
- declare
- N : constant Integer := Integer (Get_Nat);
- begin
- ALIs.Table (Id).Restrictions.Value (RP) := N;
+ if Cumulative_Restrictions.Set (RP) then
+ Cumulative_Restrictions.Value (RP) :=
+ Integer'Min
+ (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
- Cumulative_Restrictions.Value (RP) :=
- Integer'Min
- (Cumulative_Restrictions.Value (RP), N);
- else
- Cumulative_Restrictions.Set (RP) := True;
- Cumulative_Restrictions.Value (RP) := N;
- end if;
- end;
+ when others =>
+ raise Bad_R_Line;
+ end case;
- when others =>
- raise Bad_R_Line;
- end case;
+ -- Acquire restrictions violations information
- -- Acquire restrictions violations information
+ case Getc is
- case Getc is
when 'n' =>
null;
declare
N : constant Integer := Integer (Get_Nat);
- pragma Unsuppress (Overflow_Check);
begin
ALIs.Table (Id).Restrictions.Count (RP) := N;
Cumulative_Restrictions.Count (RP) :=
Integer'Max
(Cumulative_Restrictions.Count (RP), N);
+
else
- Cumulative_Restrictions.Count (RP) :=
- Cumulative_Restrictions.Count (RP) + N;
- end if;
+ declare
+ pragma Unsuppress (Overflow_Check);
- exception
- when Constraint_Error =>
+ begin
+ Cumulative_Restrictions.Count (RP) :=
+ Cumulative_Restrictions.Count (RP) + N;
+
+ exception
+ when Constraint_Error =>
- -- A constraint error comes from the addition in
- -- the else branch. We reset to the maximum and
- -- indicate that the real value is now unknown.
+ -- A constraint error comes from the add. We
+ -- reset to the maximum and indicate that the
+ -- 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;
+ end if;
end;
- if Nextc = '+' then
- Skipc;
- ALIs.Table (Id).Restrictions.Unknown (RP) := True;
- Cumulative_Restrictions.Unknown (RP) := True;
- end if;
-
when others =>
raise Bad_R_Line;
- end case;
- end loop;
+ end case;
+ 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
when Bad_R_Line =>
-- 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
Cumulative_Restrictions := Save_R;
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
else
Fatal_Error;
end if;
-
end Scan_Restrictions;
end if;
-- Acquire additional restrictions (No_Dependence) lines if present
- C := Getc;
while C = 'R' loop
if Ignore ('R') then
Skip_Line;
-- d.O Dump internal SCO tables
-- d.P Previous (non-optimized) handling of length comparisons
-- d.Q
- -- d.R
+ -- d.R Restrictions in ali files in positional form
-- d.S Force Optimize_Alignment (Space)
-- d.T Force Optimize_Alignment (Time)
-- d.U Ignore indirect calls for static elaboration
-- This is there in case we find a situation where the optimization
-- 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.T Force Optimize_Alignment (Time) mode as the default
with ALI; use ALI;
with Atree; use Atree;
with Casing; use Casing;
+with Debug; use Debug;
with Einfo; use Einfo;
with Errout; use Errout;
with Fname; use Fname;
end if;
end loop;
- -- Output first restrictions line
+ -- Positional case (only if debug flag -gnatd.R is set)
- Write_Info_Initiate ('R');
- Write_Info_Char (' ');
+ if Debug_Flag_Dot_RR then
- -- First the information for the boolean restrictions
+ -- Output first restrictions line
- for R in All_Boolean_Restrictions loop
- if Main_Restrictions.Set (R)
- 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;
+ Write_Info_Initiate ('R');
+ Write_Info_Char (' ');
- -- And now the information for the parameter restrictions
+ -- First the information for the boolean restrictions
- for RP in All_Parameter_Restrictions loop
- if Main_Restrictions.Set (RP)
- and then not Restriction_Warnings (RP)
- then
- Write_Info_Char ('r');
- Write_Info_Nat (Nat (Main_Restrictions.Value (RP)));
- else
- Write_Info_Char ('n');
- end if;
+ for R in All_Boolean_Restrictions loop
+ if Main_Restrictions.Set (R)
+ 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;
- 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)));
+ -- And now the information 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_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
- Write_Info_Char ('+');
+ if Main_Restrictions.Unknown (RP) then
+ Write_Info_Char ('+');
+ 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
-- -- 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
-- Restrictions encountered, as well as information on what the compiler
-- has been able to determine with respect to restrictions violations.
-- signal a fatal error if it is missing. This means that future
-- 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
-- is used. There is one such line for each such pragma appearing in the
-- extended main unit. The format is:
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
-- 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
- -- handle calls to Set_SCO_Pragma_Enabled. For this purpose we identify
- -- the conditions and pragmas in the table by their starting sloc, and use
- -- this hash table to map from these sloc values to SCO_Table indexes.
+ -- handle calls to Set_SCO_Pragma_Enabled. For this purpose we identify the
+ -- conditions and pragmas in the table by their starting sloc, and use this
+ -- hash table to map from these sloc values to SCO_Table indexes.
type Header_Num is new Integer range 0 .. 996;
-- Type for hash table headers
-- F/T/S/E for a valid dominance marker, or ' ' for no dominant
N : Node_Id;
- -- Node providing the sloc(s) for the dominance marker
+ -- Node providing the Sloc(s) for the dominance marker
end record;
No_Dominant : constant Dominant_Info := (' ', Empty);
procedure Traverse_Declarations_Or_Statements
(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_Package_Declaration (N : Node_Id);
function Is_Logical_Operator (N : Node_Id) return Boolean is
begin
- return Nkind_In (N, N_Op_Not,
- N_And_Then,
- N_Or_Else);
+ return Nkind_In (N, N_Op_Not, N_And_Then, N_Or_Else);
end Is_Logical_Operator;
-----------------------
procedure Output_Header (T : Character) is
Loc : Source_Ptr := No_Location;
- -- Node whose sloc is used for the decision
+ -- Node whose Sloc is used for the decision
begin
case T is
when 'G' | 'P' =>
- -- For entry, the token sloc is from the N_Entry_Body. For
- -- PRAGMA, we must get the location from the pragma node.
+ -- For entry guard, the token sloc is from the N_Entry_Body.
+ -- For PRAGMA, we must get the location from the pragma node.
-- Argument N is the pragma argument, and we have to go up two
-- levels (through the pragma argument association) to get to
- -- the pragma node itself.
-
- Loc := Sloc (Parent (Parent (N)));
+ -- the pragma node itself. For the guard on a select
+ -- alternative, we do not have access to the token location
+ -- 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' =>
-- 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 =>
-
+ when N_And_Then | N_Or_Else | N_Op_Not =>
declare
T : Character;
procedure Traverse_Declarations_Or_Statements
(L : List_Id;
- D : Dominant_Info := No_Dominant)
+ D : Dominant_Info := No_Dominant;
+ P : Node_Id := Empty)
is
Current_Dominant : Dominant_Info := D;
-- Dominance information for the current basic block
Current_Test : Node_Id;
-- Conditional node (N_If_Statement or N_Elsiif being processed
- N : Node_Id;
- Dummy : Source_Ptr;
+ N : Node_Id;
SC_First : constant Nat := SC.Last + 1;
SD_First : constant Nat := SD.Last + 1;
-- is the letter that identifies the type of statement/declaration that
-- 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;
-- Output CS entries for all statements saved in table SC, and end the
-- current CS sequence.
pragma Inline (Process_Decisions_Defer);
-- Same case for list arguments, deferred call to Process_Decisions
+ procedure Traverse_One (N : Node_Id);
+ -- Traverse one declaration or statement
+
-------------------------
-- Set_Statement_Entry --
-------------------------
-------------------------------
procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is
- F : Source_Ptr;
- T : Source_Ptr;
+ F : Source_Ptr;
+ T : Source_Ptr;
+ Dummy : Source_Ptr;
+ To_Node : Node_Id := Empty;
+
begin
Sloc_Range (N, F, T);
- SC.Append ((N, F, T, Typ));
- end Extend_Statement_Sequence;
- procedure Extend_Statement_Sequence
- (From : Node_Id;
- To : Node_Id;
- Typ : Character)
- is
- F : Source_Ptr;
- T : Source_Ptr;
- begin
- Sloc_Range (From, F, Dummy);
- Sloc_Range (To, Dummy, T);
- SC.Append ((From, F, T, Typ));
+ case Nkind (N) is
+ when N_Accept_Statement =>
+ if Present (Parameter_Specifications (N)) then
+ To_Node := Last (Parameter_Specifications (N));
+ elsif Present (Entry_Index (N)) then
+ To_Node := Entry_Index (N);
+ end if;
+
+ when N_Case_Statement =>
+ To_Node := Expression (N);
+
+ 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;
-----------------------------
SD.Append ((Empty, L, T, Current_Pragma_Sloc));
end Process_Decisions_Defer;
- -- Start of processing for Traverse_Declarations_Or_Statements
+ ------------------
+ -- Traverse_One --
+ ------------------
- begin
- if Is_Non_Empty_List (L) then
+ procedure Traverse_One (N : Node_Id) is
+ 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);
- while Present (N) loop
+ -- Package declaration
- -- 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.
+ when N_Package_Declaration =>
+ Set_Statement_Entry;
+ Traverse_Package_Declaration (N);
- 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 =>
- Set_Statement_Entry;
- Traverse_Package_Declaration (N);
+ -- Package body
- -- Generic package declaration
+ when N_Package_Body =>
+ Set_Statement_Entry;
+ Traverse_Package_Body (N);
- when N_Generic_Package_Declaration =>
- Set_Statement_Entry;
- Traverse_Generic_Package_Declaration (N);
+ -- Subprogram declaration
- -- Package body
+ when N_Subprogram_Declaration =>
+ Process_Decisions_Defer
+ (Parameter_Specifications (Specification (N)), 'X');
- when N_Package_Body =>
- Set_Statement_Entry;
- Traverse_Package_Body (N);
+ -- Generic subprogram declaration
+
+ 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 =>
- Process_Decisions_Defer
- (Parameter_Specifications (Specification (N)), 'X');
+ when N_Task_Body | N_Subprogram_Body =>
+ Set_Statement_Entry;
+ Traverse_Subprogram_Or_Task_Body (N);
- -- Generic subprogram declaration
+ -- Entry body
- when N_Generic_Subprogram_Declaration =>
- Process_Decisions_Defer
- (Generic_Formal_Declarations (N), 'X');
- Process_Decisions_Defer
- (Parameter_Specifications (Specification (N)), 'X');
+ when N_Entry_Body =>
+ declare
+ Cond : constant Node_Id :=
+ Condition (Entry_Body_Formal_Part (N));
- -- Task or subprogram body
+ Inner_Dominant : Dominant_Info := No_Dominant;
- when N_Task_Body | N_Subprogram_Body =>
+ begin
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
- Cond : constant Node_Id :=
- Condition (Entry_Body_Formal_Part (N));
- Inner_Dominant : Dominant_Info := No_Dominant;
- begin
- Set_Statement_Entry;
+ Saved_Dominant : constant Dominant_Info :=
+ Current_Dominant;
- if Present (Cond) then
- Process_Decisions_Defer (Cond, 'G');
+ Elif : Node_Id := First (Elsif_Parts (N));
- -- For an entry body with a barrier, the entry body
- -- is dominanted by a True evaluation of the barrier.
+ begin
+ while Present (Elif) loop
- Inner_Dominant := ('T', N);
- end if;
+ -- An Elsif is executed only if the previous test
+ -- got a FALSE outcome.
- Traverse_Subprogram_Or_Task_Body (N, Inner_Dominant);
- end;
+ Current_Dominant := ('F', Current_Test);
- -- Protected body
+ -- Now update current test information
- when N_Protected_Body =>
- Set_Statement_Entry;
- Traverse_Protected_Body (N);
+ Current_Test := Elif;
- -- 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.
+ -- We generate a statement sequence for the
+ -- construct "ELSIF condition", so that we have
+ -- a statement for the resulting decisions.
- when N_Exit_Statement =>
- Extend_Statement_Sequence (N, ' ');
- Process_Decisions_Defer (Condition (N), 'E');
- Set_Statement_Entry;
+ Extend_Statement_Sequence (Elif, 'I');
+ Process_Decisions_Defer (Condition (Elif), 'I');
+ Set_Statement_Entry;
- -- If condition is present, then following statement is
- -- only executed if the condition evaluates to False.
+ -- An ELSIF part is never guaranteed to have
+ -- been executed, following statements are only
+ -- dominated by the initial IF statement.
- if Present (Condition (N)) then
- Current_Dominant := ('F', N);
- else
- Current_Dominant := No_Dominant;
- end if;
+ Current_Dominant := Saved_Dominant;
- -- Label, which breaks the current statement sequence, but the
- -- label itself is not included in the next statement sequence,
- -- since it generates no code.
+ -- Traverse the statements in the ELSIF
- when N_Label =>
- Set_Statement_Entry;
- Current_Dominant := No_Dominant;
+ Traverse_Declarations_Or_Statements
+ (L => Then_Statements (Elif),
+ 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 =>
- 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);
+ Traverse_Declarations_Or_Statements
+ (L => Else_Statements (N),
+ D => ('F', Current_Test));
- -- If statement, which breaks the current statement sequence,
- -- but we include the condition in the current sequence.
+ -- CASE statement, which breaks the current statement sequence,
+ -- but we include the expression in the current sequence.
- when N_If_Statement =>
- Current_Test := N;
- Extend_Statement_Sequence (N, Condition (N), 'I');
- Process_Decisions_Defer (Condition (N), 'I');
- Set_Statement_Entry;
+ when N_Case_Statement =>
+ Extend_Statement_Sequence (N, 'C');
+ Process_Decisions_Defer (Expression (N), 'X');
+ 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
- (L => Then_Statements (N),
- D => ('T', N));
+ declare
+ Alt : Node_Id;
+ 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
- declare
- Saved_Dominant : constant Dominant_Info :=
- Current_Dominant;
- Elif : Node_Id := First (Elsif_Parts (N));
+ when N_Accept_Statement =>
+ Extend_Statement_Sequence (N, 'A');
+ Set_Statement_Entry;
- begin
- while Present (Elif) loop
+ -- Process sequence of statements, dominant is the ACCEPT
+ -- statement.
- -- An Elsif is executed only if the previous test
- -- got a FALSE outcome.
+ Traverse_Handled_Statement_Sequence
+ (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
- -- construct "ELSIF condition", so that we have
- -- a statement for the resulting decisions.
+ declare
+ Alt : Node_Id;
+ 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
- (Elif, Condition (Elif), 'I');
- Process_Decisions_Defer (Condition (Elif), 'I');
- Set_Statement_Entry;
+ Traverse_One (Alt);
- -- An ELSIF part is never guaranteed to have
- -- been executed, following statements are only
- -- dominated by the initial IF statement.
+ Current_Dominant := S_Dom;
+ Next (Alt);
+ 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
- (L => Then_Statements (Elif),
- D => ('T', Elif));
- Next (Elif);
- end loop;
- end;
- end if;
+ -- Process alternatives
- -- 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
(L => Else_Statements (N),
- D => ('F', Current_Test));
+ D => Current_Dominant);
+ end if;
- -- Case statement, which breaks the current statement sequence,
- -- but we include the expression in the current sequence.
+ when N_Asynchronous_Select =>
+ Extend_Statement_Sequence (N, 'S');
+ Set_Statement_Entry;
- when N_Case_Statement =>
- Extend_Statement_Sequence (N, Expression (N), 'C');
- Process_Decisions_Defer (Expression (N), 'X');
- Set_Statement_Entry;
+ Traverse_One (Triggering_Alternative (N));
+ Traverse_Declarations_Or_Statements
+ (L => Statements (Abortable_Part (N)),
+ D => Current_Dominant);
- -- Process case branches, all of which are dominated by the
- -- CASE statement.
+ when N_Accept_Alternative =>
+ Traverse_Declarations_Or_Statements
+ (L => Statements (N),
+ D => Current_Dominant,
+ P => Accept_Statement (N));
- declare
- Alt : Node_Id;
- begin
- Alt := First (Alternatives (N));
- while Present (Alt) loop
- Traverse_Declarations_Or_Statements
- (L => Statements (Alt),
- D => Current_Dominant);
- Next (Alt);
- end loop;
- end;
+ when N_Entry_Call_Alternative =>
+ Traverse_Declarations_Or_Statements
+ (L => Statements (N),
+ D => Current_Dominant,
+ P => Entry_Call_Statement (N));
+
+ when N_Delay_Alternative =>
+ Traverse_Declarations_Or_Statements
+ (L => Statements (N),
+ D => Current_Dominant,
+ P => Delay_Statement (N));
- -- Unconditional exit points, which are included in the current
- -- statement sequence, but then terminate it
+ when N_Triggering_Alternative =>
+ Traverse_Declarations_Or_Statements
+ (L => Statements (N),
+ D => Current_Dominant,
+ P => Triggering_Statement (N));
- when N_Requeue_Statement |
- N_Goto_Statement |
- N_Raise_Statement =>
- Extend_Statement_Sequence (N, ' ');
- Set_Statement_Entry;
- Current_Dominant := No_Dominant;
+ when N_Terminate_Alternative =>
+ Extend_Statement_Sequence (N, ' ');
+ Set_Statement_Entry;
- -- Simple return statement. which is an exit point, but we
- -- have to process the return expression for decisions.
+ -- Unconditional exit points, which are included in the current
+ -- statement sequence, but then terminate it
- when N_Simple_Return_Statement =>
- Extend_Statement_Sequence (N, ' ');
- Process_Decisions_Defer (Expression (N), 'X');
- Set_Statement_Entry;
- Current_Dominant := No_Dominant;
+ when N_Requeue_Statement |
+ N_Goto_Statement |
+ N_Raise_Statement =>
+ Extend_Statement_Sequence (N, ' ');
+ 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 =>
- Extend_Statement_Sequence
- (N, Last (Return_Object_Declarations (N)), 'R');
- Process_Decisions_Defer
- (Return_Object_Declarations (N), 'X');
- Set_Statement_Entry;
+ when N_Simple_Return_Statement =>
+ Extend_Statement_Sequence (N, ' ');
+ Process_Decisions_Defer (Expression (N), 'X');
+ Set_Statement_Entry;
+ Current_Dominant := No_Dominant;
- Traverse_Handled_Statement_Sequence
- (N => Handled_Statement_Sequence (N),
- D => Current_Dominant);
+ -- Extended return statement
- 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
- -- 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.
+ Traverse_Handled_Statement_Sequence
+ (N => Handled_Statement_Sequence (N),
+ D => Current_Dominant);
- when N_Loop_Statement =>
- declare
- ISC : constant Node_Id := Iteration_Scheme (N);
- Inner_Dominant : Dominant_Info := No_Dominant;
+ Current_Dominant := No_Dominant;
- begin
- if Present (ISC) then
+ -- Loop ends the current statement sequence, but we include
+ -- 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
- -- statement sequence to include the iteration scheme
- -- and process any decisions it contains.
+ when N_Loop_Statement =>
+ declare
+ 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
- Extend_Statement_Sequence (N, ISC, 'W');
- Process_Decisions_Defer (Condition (ISC), 'W');
+ -- If iteration scheme present, extend the current
+ -- statement sequence to include the iteration scheme
+ -- and process any decisions it contains.
- -- Set more specific dominant for inner statements
- -- (the control sloc for the decision is that of
- -- the WHILE token).
+ -- While loop
- 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
- Extend_Statement_Sequence (N, ISC, 'F');
- Process_Decisions_Defer
- (Loop_Parameter_Specification (ISC), 'X');
- end if;
- end if;
+ Inner_Dominant := ('T', ISC);
- Set_Statement_Entry;
+ -- For loop
- if Inner_Dominant = No_Dominant then
- Inner_Dominant := Current_Dominant;
+ else
+ Extend_Statement_Sequence (N, 'F');
+ Process_Decisions_Defer
+ (Loop_Parameter_Specification (ISC), 'X');
end if;
+ end if;
- Traverse_Declarations_Or_Statements
- (L => Statements (N),
- D => Inner_Dominant);
- end;
+ Set_Statement_Entry;
- -- 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);
- Current_Pragma_Sloc := Sloc (N);
+ when N_Pragma =>
- -- Processing depends on the kind of pragma
+ -- Record sloc of pragma (pragmas don't nest)
- declare
- Nam : constant Name_Id := Pragma_Name (N);
- Arg : Node_Id := First (Pragma_Argument_Associations (N));
- Typ : Character;
+ pragma Assert (Current_Pragma_Sloc = No_Location);
+ Current_Pragma_Sloc := Sloc (N);
- begin
- 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;
+ -- Processing depends on the kind of pragma
- Process_Decisions_Defer (Expression (Arg), 'P');
- Typ := 'p';
+ declare
+ Nam : constant Name_Id := Pragma_Name (N);
+ Arg : Node_Id :=
+ First (Pragma_Argument_Associations (N));
+ Typ : Character;
- when Name_Debug =>
- if Present (Arg) and then Present (Next (Arg)) then
+ begin
+ 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
- -- is a P decision, any nested decision in the
- -- second argument is an X decision.
+ Process_Decisions_Defer (Expression (Arg), 'P');
+ Typ := 'p';
- Process_Decisions_Defer (Expression (Arg), 'P');
- Next (Arg);
- end if;
+ when Name_Debug =>
+ if Present (Arg) and then Present (Next (Arg)) then
- Process_Decisions_Defer (Expression (Arg), 'X');
- Typ := 'p';
+ -- Case of a dyadic pragma Debug: first argument
+ -- is a P decision, any nested decision in the
+ -- second argument is an X decision.
- -- For all other pragmas, we generate decision entries
- -- for any embedded expressions, and the pragma is
- -- never disabled.
+ Process_Decisions_Defer (Expression (Arg), 'P');
+ Next (Arg);
+ end if;
- when others =>
- Process_Decisions_Defer (N, 'X');
- Typ := 'P';
- end case;
+ Process_Decisions_Defer (Expression (Arg), 'X');
+ Typ := 'p';
- -- 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;
- end;
+ -- Add statement SCO
- -- Object declaration. Ignored if Prev_Ids is set, since the
- -- 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.
+ Extend_Statement_Sequence (N, Typ);
- when N_Object_Declaration =>
- if not Prev_Ids (N) then
- Extend_Statement_Sequence (N, 'o');
+ Current_Pragma_Sloc := No_Location;
+ end;
- if Has_Decision (N) then
- Process_Decisions_Defer (N, 'X');
- end if;
- end if;
+ -- Object declaration. Ignored if Prev_Ids is set, since the
+ -- 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.
- -- All other cases, which extend the current statement sequence
- -- but do not terminate it, even if they have nested decisions.
+ when N_Object_Declaration =>
+ 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
- -- no SCO should be generated for this node.
+ -- All other cases, which extend the current statement sequence
+ -- but do not terminate it, even if they have nested decisions.
- declare
- Typ : Character;
+ when others =>
- begin
- case Nkind (N) is
- when N_Full_Type_Declaration |
- N_Incomplete_Type_Declaration |
- N_Private_Type_Declaration |
- N_Private_Extension_Declaration =>
- Typ := 't';
+ -- Determine required type character code, or ASCII.NUL if
+ -- no SCO should be generated for this node.
- when N_Subtype_Declaration =>
- Typ := 's';
+ declare
+ Typ : Character;
- when N_Renaming_Declaration =>
- Typ := 'r';
+ begin
+ 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 =>
- Typ := 'i';
+ when N_Subtype_Declaration =>
+ Typ := 's';
- when N_Representation_Clause |
- N_Use_Package_Clause |
- N_Use_Type_Clause =>
- Typ := ASCII.NUL;
+ when N_Renaming_Declaration =>
+ Typ := 'r';
- when others =>
- Typ := ' ';
- end case;
+ when N_Generic_Instantiation =>
+ Typ := 'i';
- if Typ /= ASCII.NUL then
- Extend_Statement_Sequence (N, Typ);
- end if;
- end;
+ when N_Representation_Clause |
+ N_Use_Package_Clause |
+ N_Use_Type_Clause =>
+ Typ := ASCII.NUL;
- -- Process any embedded decisions
+ when others =>
+ Typ := ' ';
+ end case;
- if Has_Decision (N) then
- Process_Decisions_Defer (N, 'X');
+ if Typ /= ASCII.NUL then
+ Extend_Statement_Sequence (N, Typ);
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);
end loop;
then
null;
- -- Here if restriction set, check for violation (either this is a
- -- Boolean restriction, or a parameter restriction with a value of
- -- zero and an unknown count, or a parameter restriction with a
- -- known value that exceeds the restriction count).
+ -- Here if restriction set, check for violation (this is a Boolean
+ -- restriction, or a parameter restriction with a value of zero and an
+ -- unknown count, or a parameter restriction with a known value that
+ -- exceeds the restriction count).
elsif R in All_Boolean_Restrictions
or else (Restrictions.Unknown (R)
----------------------------------
-- 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
is
-- exception propagation is activated.
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
- -- is one of synonyms that we allow for historical purposes (for list see
- -- Rident), then the proper official name is returned. Otherwise the Chars
- -- field of the argument is returned unchanged.
+ -- Id is a node whose Chars field contains the name of a restriction.
+ -- If it is one of synonyms that we allow for historical purposes (for
+ -- list see System.Rident), then the proper official name is returned.
+ -- Otherwise the Chars field of the argument is returned unchanged.
function Restriction_Active (R : All_Restrictions) return Boolean;
pragma Inline (Restriction_Active);
-- it can be used by the binder without dragging in unneeded compiler
-- 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
- -- identifiers that are implemented in GNAT.
+-- Rather than have clients instantiate System.Rident directly, we have the
+-- 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
- -- used in the pragma, and add calls to the Restrict.Check_Restriction
- -- routine as appropriate.
+with System.Rident;
- type Restriction_Id is
-
- -- 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;
+package Rident is new System.Rident;
------------------------------------------------------------------------------
package body System.Atomic_Primitives is
+
---------------------------
-- Lock_Free_Try_Write_8 --
---------------------------
function Lock_Free_Try_Write_8
- (Ptr : Address;
- Expected : in out uint8;
- Desired : uint8) return Boolean
+ (Ptr : Address;
+ Expected : in out uint8;
+ Desired : uint8) return Boolean
is
Actual : uint8;
----------------------------
function Lock_Free_Try_Write_16
- (Ptr : Address;
- Expected : in out uint16;
- Desired : uint16) return Boolean
+ (Ptr : Address;
+ Expected : in out uint16;
+ Desired : uint16) return Boolean
is
Actual : uint16;
----------------------------
function Lock_Free_Try_Write_32
- (Ptr : Address;
- Expected : in out uint32;
- Desired : uint32) return Boolean
+ (Ptr : Address;
+ Expected : in out uint32;
+ Desired : uint32) return Boolean
is
Actual : uint32;
----------------------------
function Lock_Free_Try_Write_64
- (Ptr : Address;
- Expected : in out uint64;
- Desired : uint64) return Boolean
+ (Ptr : Address;
+ Expected : in out uint64;
+ Desired : uint64) return Boolean
is
Actual : uint64;
(Atomic_Load_64 (Ptr, Acquire));
function Lock_Free_Try_Write_8
- (Ptr : Address;
- Expected : in out uint8;
- Desired : uint8) return Boolean;
+ (Ptr : Address;
+ Expected : in out uint8;
+ Desired : uint8) return Boolean;
function Lock_Free_Try_Write_16
- (Ptr : Address;
- Expected : in out uint16;
- Desired : uint16) return Boolean;
+ (Ptr : Address;
+ Expected : in out uint16;
+ Desired : uint16) return Boolean;
function Lock_Free_Try_Write_32
- (Ptr : Address;
- Expected : in out uint32;
- Desired : uint32) return Boolean;
+ (Ptr : Address;
+ Expected : in out uint32;
+ Desired : uint32) return Boolean;
function Lock_Free_Try_Write_64
- (Ptr : Address;
- Expected : in out uint64;
- Desired : uint64) return Boolean;
+ (Ptr : Address;
+ Expected : in out uint64;
+ Desired : uint64) return Boolean;
pragma Inline (Lock_Free_Read_8);
pragma Inline (Lock_Free_Read_16);
------------------------------------------------------------------------------
-- This package defines the set of restriction identifiers. It is a generic
--- package that is instantiated by the binder for output of the restrictions
--- structure, and is instantiated in package System.Restrictions for use at
--- run-time.
+-- package that is instantiated by the compiler/binder in package Rident, and
+-- is instantiated in package System.Restrictions for use at run-time.
-- 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 enumeration types, which are needed for diagnostic and informational
--- messages as well as for identification of restrictions. At run-time we
--- really do not want to waste the space for these image tables, and they are
--- not needed, so we can do the instantiation under control of Discard_Names
--- to remove the tables.
+-- the instantiation in Rident for use at compile time and bind time, we can
+-- generate normal image tables for the enumeration types, which are needed
+-- for diagnostic and informational messages. At run-time we really do not
+-- want to waste the space for these image tables, and they are not needed,
+-- so we can do the instantiation under control of Discard_Names to remove
+-- 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;
-- o object declaration
-- r renaming declaration
-- 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
- -- F FOR loop (from FOR through end of iteration scheme)
- -- I IF statement (from IF through end of condition)
+ -- F FOR loop (from FOR to end of iteration scheme)
+ -- I IF statement (from IF to end of condition)
-- P[name:] PRAGMA with the indicated name
-- p[name:] disabled PRAGMA with the indicated name
-- 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
-- condition is a decision in SCO terminology).
-- 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
-- No_Dependence => Ada.Asynchronous_Task_Control
projects / gcc.git / commitdiff