diff options
| author | Arnaud Charlet <charlet@gcc.gnu.org> | 2012-07-12 12:49:10 +0200 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2012-07-12 12:49:10 +0200 |
| commit | 727e7b1a870bdc057c4cb6d7d09ef1b56a84f222 (patch) | |
| tree | 9754099aee8625dc123639e1fe1bb60689179ee3 /gcc | |
| parent | 03459f403ea66cc694767e8ca351cf6550e148a7 (diff) | |
| download | gcc-727e7b1a870bdc057c4cb6d7d09ef1b56a84f222.zip gcc-727e7b1a870bdc057c4cb6d7d09ef1b56a84f222.tar.gz gcc-727e7b1a870bdc057c4cb6d7d09ef1b56a84f222.tar.bz2 | |
[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
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 21 | ||||
| -rw-r--r-- | gcc/ada/ali.adb | 318 | ||||
| -rw-r--r-- | gcc/ada/debug.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/lib-writ.adb | 151 | ||||
| -rw-r--r-- | gcc/ada/lib-writ.ads | 90 | ||||
| -rw-r--r-- | gcc/ada/par_sco.adb | 851 | ||||
| -rw-r--r-- | gcc/ada/restrict.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/restrict.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/rident.ads | 420 | ||||
| -rw-r--r-- | gcc/ada/s-atopri.adb | 25 | ||||
| -rw-r--r-- | gcc/ada/s-atopri.ads | 24 | ||||
| -rw-r--r-- | gcc/ada/s-rident.ads | 45 | ||||
| -rw-r--r-- | gcc/ada/scos.ads | 10 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 2 |
14 files changed, 1072 insertions, 910 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e83f1a7..fa75541 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,26 @@ 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 * s-bytswa.ads: Minor comment update. diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 28307ac..86ad184 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -135,7 +135,7 @@ package body ALI is 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; @@ -1154,7 +1154,7 @@ package body ALI is C := Getc; Check_Unknown_Line; - -- Acquire first restrictions line + -- Loop to skip to first restrictions line while C /= 'R' loop if Ignore_Errors then @@ -1169,10 +1169,15 @@ package body ALI is 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 @@ -1182,16 +1187,191 @@ package body ALI is 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; @@ -1205,44 +1385,42 @@ package body ALI is 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; @@ -1252,7 +1430,6 @@ package body ALI is declare N : constant Integer := Integer (Get_Nat); - pragma Unsuppress (Overflow_Check); begin ALIs.Table (Id).Restrictions.Count (RP) := N; @@ -1261,34 +1438,47 @@ package body ALI is 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 @@ -1296,25 +1486,29 @@ package body ALI is 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; diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index cbcdf0c..33f99c6 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -135,7 +135,7 @@ package body Debug is -- 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 @@ -642,6 +642,11 @@ package body Debug is -- 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 diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 29b435a..1c55a06 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -26,6 +26,7 @@ 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; @@ -1140,52 +1141,128 @@ package body Lib.Writ is 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 diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index 204ba3a..fdc9948 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -262,6 +262,28 @@ package Lib.Writ is -- -- 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. @@ -348,6 +370,74 @@ package Lib.Writ is -- 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: diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index 28fa186..766621a 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -69,9 +69,9 @@ package body Par_SCO is -- 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 @@ -133,13 +133,16 @@ package body Par_SCO is -- 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); @@ -328,9 +331,7 @@ package body Par_SCO is 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; ----------------------- @@ -475,7 +476,7 @@ package body Par_SCO is 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 @@ -488,13 +489,22 @@ package body Par_SCO 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' => @@ -547,10 +557,7 @@ package body Par_SCO is -- Logical operators, output table entries and then process -- operands recursively to deal with nested conditions. - when N_And_Then | - N_Or_Else | - N_Op_Not => - + when N_And_Then | N_Or_Else | N_Op_Not => declare T : Character; @@ -1036,7 +1043,8 @@ package body Par_SCO is 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 @@ -1044,8 +1052,7 @@ package body Par_SCO is 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; @@ -1056,15 +1063,6 @@ package body Par_SCO is -- 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. @@ -1080,6 +1078,9 @@ package body Par_SCO is 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 -- ------------------------- @@ -1180,24 +1181,50 @@ package body Par_SCO is ------------------------------- 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; ----------------------------- @@ -1214,430 +1241,548 @@ package body Par_SCO is 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; diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index 4e428c4..6b3dc2a 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -541,10 +541,10 @@ package body Restrict is 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) @@ -768,7 +768,7 @@ package body Restrict is ---------------------------------- -- 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 diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index d7b05d4..1d9d67f 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -332,10 +332,10 @@ package Restrict 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); diff --git a/gcc/ada/rident.ads b/gcc/ada/rident.ads index 2408714..615e17b 100644 --- a/gcc/ada/rident.ads +++ b/gcc/ada/rident.ads @@ -34,416 +34,16 @@ -- 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; diff --git a/gcc/ada/s-atopri.adb b/gcc/ada/s-atopri.adb index af52128..ed5ca53 100644 --- a/gcc/ada/s-atopri.adb +++ b/gcc/ada/s-atopri.adb @@ -30,14 +30,15 @@ ------------------------------------------------------------------------------ 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; @@ -59,9 +60,9 @@ package body System.Atomic_Primitives is ---------------------------- 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; @@ -83,9 +84,9 @@ package body System.Atomic_Primitives is ---------------------------- 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; @@ -107,9 +108,9 @@ package body System.Atomic_Primitives is ---------------------------- 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; diff --git a/gcc/ada/s-atopri.ads b/gcc/ada/s-atopri.ads index c0a9703..bc58806 100644 --- a/gcc/ada/s-atopri.ads +++ b/gcc/ada/s-atopri.ads @@ -152,24 +152,24 @@ package System.Atomic_Primitives is (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); diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads index 11943f0..880a729 100644 --- a/gcc/ada/s-rident.ads +++ b/gcc/ada/s-rident.ads @@ -30,17 +30,44 @@ ------------------------------------------------------------------------------ -- 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; diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads index e0e31b6..9f47898 100644 --- a/gcc/ada/scos.ads +++ b/gcc/ada/scos.ads @@ -152,14 +152,16 @@ package SCOs is -- 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). diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index e5ed869..ecec30f 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -6254,7 +6254,7 @@ package body Sem_Prag is -- 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 |