OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2004-02-09  Ed Schonberg  <schonberg@gnat.com>

	* exp_ch4.adb (Expand_N_Op_Eq): When looking for the primitive equality
	for a tagged type, verify that both formals have the same type.

	* exp_ch6.adb (Add_Call_By_Copy_Code): Initialize properly the
	temporary when the formal is an in-parameter and the actual a possibly
	unaligned slice.

	* exp_ch9.adb (Expand_Entry_Barrier): Resolve barrier expression even
	when expansion is disabled, to ensure proper name capture with
	overloaded literals.  Condition can be of any boolean type, resolve
	accordingly.

	* sem_ch8.adb (Analyze_Subprogram_Renaming): Emit warning if the
	renaming is for a formal subprogram with a default operator name, and
	there is a usable operator that is visible at the point of
	instantiation.

2004-02-09  Robert Dewar  <dewar@gnat.com>

	* ali.adb (Scan_Ali) Add Ignore_Errors argument. This is a major
	rewrite to ignore errors in ali files, intended to allow tools downward
	compatibility with new versions of ali files.

	* ali.ads: Add new parameter Ignore_Errors

	* bcheck.adb (Check_Consistent_Restrictions): Fix error of sometimes
	duplicating the error message giving the file with restrictions.

	* debug.adb: Add debug flag I for gnatbind

	* errout.adb (Set_Msg_Insertion_Node): Suppress extra quotes around
	operators for the case where the operator is a defining operator.

	* exp_ch3.adb: Minor reformatting (new function spec format).

	* exp_ch4.adb: Add comment for previous change, and make minor
	adjustment to loop to always check for improper loop termination.
	Minor reformatting throughout (new function spec format).

	* gnatbind.adb: Implement -di debug flag for gnatbind

	* gnatlink.adb: Call Scan_ALI with Ignore_Errors set to True

	* gnatls.adb: Call Scan_ALI with Ignore_Errors set to True

	* lib-load.adb: Fix bad assertion.
	Found by testing and code reading.
	Minor reformatting.

	* lib-load.ads: Minor reformatting.

	* lib-writ.adb: There is only one R line now.

	* lib-writ.ads: Add documentation on making downward compatible changes
	to ali files so old tools work with new ali files.
	There is only one R line now.
	Add documentation on format incompatibilities (with special GPS note)

	* namet.ads, namet.adb: (Is_Operator_Name): New procedure

	* par-load.adb: Minor reformatting

	* sem_ch8.adb: Fix to error message from last update
	Minor reformatting and restructuring of code from last update

	* par-prag.adb, snames.adb, snames.ads, snames.h,
	sem_prag.adb: Implement pragma Profile.

	* stylesw.adb: Implement -gnatyN switch to turn off all style check
	options.

	* usage.adb: Add line for -gnatyN switch

	* vms_data.ads: Add entry STYLE_CHECKS=NONE for -gnatyN

From-SVN: r77537
This commit is contained in:
Arnaud Charlet 2004-02-09 15:56:05 +01:00
parent 77077b39cb
commit 2e0717349d
29 changed files with 1464 additions and 1048 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
gcc/ada/ChangeLog
View File

@ -1,3 +1,80 @@
2004-02-09 Ed Schonberg <schonberg@gnat.com>
* exp_ch4.adb (Expand_N_Op_Eq): When looking for the primitive equality
for a tagged type, verify that both formals have the same type.
* exp_ch6.adb (Add_Call_By_Copy_Code): Initialize properly the
temporary when the formal is an in-parameter and the actual a possibly
unaligned slice.
* exp_ch9.adb (Expand_Entry_Barrier): Resolve barrier expression even
when expansion is disabled, to ensure proper name capture with
overloaded literals. Condition can be of any boolean type, resolve
accordingly.
* sem_ch8.adb (Analyze_Subprogram_Renaming): Emit warning if the
renaming is for a formal subprogram with a default operator name, and
there is a usable operator that is visible at the point of
instantiation.
2004-02-09 Robert Dewar <dewar@gnat.com>
* ali.adb (Scan_Ali) Add Ignore_Errors argument. This is a major
rewrite to ignore errors in ali files, intended to allow tools downward
compatibility with new versions of ali files.
* ali.ads: Add new parameter Ignore_Errors
* bcheck.adb (Check_Consistent_Restrictions): Fix error of sometimes
duplicating the error message giving the file with restrictions.
* debug.adb: Add debug flag I for gnatbind
* errout.adb (Set_Msg_Insertion_Node): Suppress extra quotes around
operators for the case where the operator is a defining operator.
* exp_ch3.adb: Minor reformatting (new function spec format).
* exp_ch4.adb: Add comment for previous change, and make minor
adjustment to loop to always check for improper loop termination.
Minor reformatting throughout (new function spec format).
* gnatbind.adb: Implement -di debug flag for gnatbind
* gnatlink.adb: Call Scan_ALI with Ignore_Errors set to True
* gnatls.adb: Call Scan_ALI with Ignore_Errors set to True
* lib-load.adb: Fix bad assertion.
Found by testing and code reading.
Minor reformatting.
* lib-load.ads: Minor reformatting.
* lib-writ.adb: There is only one R line now.
* lib-writ.ads: Add documentation on making downward compatible changes
to ali files so old tools work with new ali files.
There is only one R line now.
Add documentation on format incompatibilities (with special GPS note)
* namet.ads, namet.adb: (Is_Operator_Name): New procedure
* par-load.adb: Minor reformatting
* sem_ch8.adb: Fix to error message from last update
Minor reformatting and restructuring of code from last update
* par-prag.adb, snames.adb, snames.ads, snames.h,
sem_prag.adb: Implement pragma Profile.
* stylesw.adb: Implement -gnatyN switch to turn off all style check
options.
* usage.adb: Add line for -gnatyN switch
* vms_data.ads: Add entry STYLE_CHECKS=NONE for -gnatyN
2004-02-09 Albert Lee <lee@gnat.com>
* errno.c: define _SGI_MP_SOURCE for task-safe errno on IRIX

558
gcc/ada/ali.adb
View File

@ -37,6 +37,25 @@ package body ALI is
use ASCII;
-- Make control characters visible
-- The following variable records which characters currently are
-- used as line type markers in the ALI file. This is used in
-- Scan_ALI to detect (or skip) invalid lines.
Known_ALI_Lines : constant array (Character range 'A' .. 'Z') of Boolean :=
('V' => True, -- version
'M' => True, -- main program
'A' => True, -- argument
'P' => True, -- program
'R' => True, -- restriction
'I' => True, -- interrupt
'U' => True, -- unit
'W' => True, -- with
'L' => True, -- linker option
'E' => True, -- external
'D' => True, -- dependency
'X' => True, -- xref
others => False);
--------------------
-- Initialize_ALI --
--------------------
@ -99,13 +118,14 @@ package body ALI is
--------------
function Scan_ALI
(F : File_Name_Type;
T : Text_Buffer_Ptr;
Ignore_ED : Boolean;
Err : Boolean;
Read_Xref : Boolean := False;
Read_Lines : String := "";
Ignore_Lines : String := "X") return ALI_Id
(F : File_Name_Type;
T : Text_Buffer_Ptr;
Ignore_ED : Boolean;
Err : Boolean;
Read_Xref : Boolean := False;
Read_Lines : String := "";
Ignore_Lines : String := "X";
Ignore_Errors : Boolean := False) return ALI_Id
is
P : Text_Ptr := T'First;
Line : Logical_Line_Number := 1;
@ -141,10 +161,26 @@ package body ALI is
procedure Checkc (C : Character);
-- Check next character is C. If so bump past it, if not fatal error
procedure Check_Unknown_Line;
-- If Ignore_Errors mode, then checks C to make sure that it is not
-- an unknown ALI line type characters, and if so, skips lines
-- until the first character of the line is one of these characters,
-- at which point it does a Getc to put that character in C. The
-- call has no effect if C is already an appropriate character.
-- If not in Ignore_Errors mode, a fatal error is signalled if the
-- line is unknown. Note that if C is an EOL on entry, the line is
-- skipped (it is assumed that blank lines are never significant).
-- If C is EOF on entry, the call has no effect (it is assumed that
-- the caller will properly handle this case).
procedure Fatal_Error;
-- Generate fatal error message for badly formatted ALI file if
-- Err is false, or raise Bad_ALI_Format if Err is True.
procedure Fatal_Error_Ignore;
pragma Inline (Fatal_Error_Ignore);
-- In Ignore_Errors mode, has no effect, otherwise same as Fatal_Error
function Getc return Character;
-- Get next character, bumping P past the character obtained
@ -210,7 +246,13 @@ package body ALI is
procedure Check_At_End_Of_Field is
begin
if not At_End_Of_Field then
Fatal_Error;
if Ignore_Errors then
while Nextc > ' ' loop
P := P + 1;
end loop;
else
Fatal_Error;
end if;
end if;
end Check_At_End_Of_Field;
@ -222,11 +264,38 @@ package body ALI is
begin
if Nextc = C then
P := P + 1;
elsif Ignore_Errors then
P := P + 1;
else
Fatal_Error;
end if;
end Checkc;
------------------------
-- Check_Unknown_Line --
------------------------
procedure Check_Unknown_Line is
begin
while C not in 'A' .. 'Z'
or else not Known_ALI_Lines (C)
loop
if C = CR or else C = LF then
Skip_Line;
elsif C = EOF then
return;
elsif Ignore_Errors then
Skip_Line;
C := Getc;
else
Fatal_Error;
end if;
end loop;
end Check_Unknown_Line;
-----------------
-- Fatal_Error --
-----------------
@ -323,6 +392,17 @@ package body ALI is
Exit_Program (E_Fatal);
end Fatal_Error;
------------------------
-- Fatal_Error_Ignore --
------------------------
procedure Fatal_Error_Ignore is
begin
if not Ignore_Errors then
Fatal_Error;
end if;
end Fatal_Error_Ignore;
--------------
-- Get_Name --
--------------
@ -336,7 +416,11 @@ package body ALI is
Skip_Space;
if At_Eol then
Fatal_Error;
if Ignore_Errors then
return Error_Name;
else
Fatal_Error;
end if;
end if;
loop
@ -400,7 +484,11 @@ package body ALI is
Skip_Space;
if At_Eol then
Fatal_Error;
if Ignore_Errors then
return Dummy_Time_Stamp;
else
Fatal_Error;
end if;
end if;
-- Following reads old style time stamp missing first two digits
@ -454,7 +542,15 @@ package body ALI is
begin
Skip_Space;
if not At_Eol then Fatal_Error; end if;
if not At_Eol then
if Ignore_Errors then
while not At_Eol loop
P := P + 1;
end loop;
else
Fatal_Error;
end if;
end if;
-- Loop to skip past blank lines (first time through skips this EOL)
@ -569,10 +665,16 @@ package body ALI is
-- C is set to contain the first character of the following line.
C := Getc;
Check_Unknown_Line;
-- Acquire library version
if C /= 'V' then
-- The V line missing really indicates trouble, most likely it
-- means we don't have an ALI file at all, so here we give a
-- fatal error even if we are in Ignore_Errors mode.
Fatal_Error;
elsif Ignore ('V') then
@ -594,6 +696,7 @@ package body ALI is
end if;
C := Getc;
Check_Unknown_Line;
-- Acquire main program line if present
@ -648,7 +751,10 @@ package body ALI is
First_Arg := Args.Last + 1;
Arg_Loop : while C = 'A' loop
A_Loop : loop
Check_Unknown_Line;
exit A_Loop when C /= 'A';
if Ignore ('A') then
Skip_Line;
@ -668,16 +774,29 @@ package body ALI is
end if;
C := Getc;
end loop Arg_Loop;
end loop A_Loop;
-- Acquire P line
if C /= 'P' then
Fatal_Error;
Check_Unknown_Line;
elsif Ignore ('P') then
while C /= 'P' loop
if Ignore_Errors then
if C = EOF then
Fatal_Error;
else
Skip_Line;
end if;
else
Fatal_Error;
end if;
end loop;
if Ignore ('P') then
Skip_Line;
-- Process P line
else
NS_Found := False;
@ -731,7 +850,7 @@ package body ALI is
-- Invalid switch starting with N
else
Fatal_Error;
Fatal_Error_Ignore;
end if;
-- Processing for Qx
@ -758,7 +877,7 @@ package body ALI is
-- Invalid switch starting with S
else
Fatal_Error;
Fatal_Error_Ignore;
end if;
-- Processing for Tx
@ -786,18 +905,26 @@ package body ALI is
-- Invalid switches starting with U
else
Fatal_Error;
Fatal_Error_Ignore;
end if;
-- Processing for ZX
elsif C = 'Z' then
Checkc ('X');
C := Getc;
if C = 'X' then
ALIs.Table (Id).Zero_Cost_Exceptions := True;
Zero_Cost_Exceptions_Specified := True;
else
Fatal_Error_Ignore;
end if;
-- Invalid parameter
else
Fatal_Error;
C := Getc;
Fatal_Error_Ignore;
end if;
end loop;
@ -809,149 +936,173 @@ package body ALI is
end if;
C := Getc;
Check_Unknown_Line;
-- Acquire first restrictions line
-- Acquire restrictions line
if C /= 'R' then
Fatal_Error;
while C /= 'R' loop
if Ignore_Errors then
if C = EOF then
Fatal_Error;
else
Skip_Line;
end if;
else
Fatal_Error;
end if;
end loop;
elsif Ignore ('R') then
if Ignore ('R') then
Skip_Line;
else
Checkc (' ');
Skip_Space;
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 'r' =>
ALIs.Table (Id).Restrictions.Set (R) := True;
Cumulative_Restrictions.Set (R) := True;
when 'n' =>
null;
when others =>
Fatal_Error;
end case;
end loop;
Skip_Eol;
end if;
C := Getc;
-- See if we have a second R line
if C /= 'R' then
-- If not, just ignore, and leave the restrictions variables
-- unchanged. This is useful for dealing with old format ALI
-- files with only one R line (this can be removed later on,
-- but is useful for transitional purposes).
null;
-- Here we have a second R line, ignore it if ignore flag set
elsif Ignore ('R') then
Skip_Line;
C := Getc;
-- Otherwise acquire second R line
-- Process restrictions line
else
Checkc (' ');
Skip_Space;
Scan_Restrictions : declare
Save_R : constant Restrictions_Info := Cumulative_Restrictions;
-- Save cumulative restrictions in case we have a fatal error
for RP in All_Parameter_Restrictions loop
Bad_R_Line : exception;
-- Signal bad restrictions line
-- Acquire restrictions pragma information
begin
Checkc (' ');
Skip_Space;
case Getc is
when 'n' =>
null;
-- Acquire information for boolean restrictions
when 'r' =>
ALIs.Table (Id).Restrictions.Set (RP) := True;
for R in All_Boolean_Restrictions loop
C := Getc;
declare
N : constant Integer := Integer (Get_Nat);
begin
ALIs.Table (Id).Restrictions.Value (RP) := N;
case C is
when 'v' =>
ALIs.Table (Id).Restrictions.Violated (R) := True;
Cumulative_Restrictions.Violated (R) := True;
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 'r' =>
ALIs.Table (Id).Restrictions.Set (R) := True;
Cumulative_Restrictions.Set (R) := True;
when others =>
Fatal_Error;
end case;
when 'n' =>
null;
-- Acquire restrictions violations information
when others =>
Fatal_Error;
end case;
end loop;
case Getc is
when 'n' =>
null;
-- Skip separating space
when 'v' =>
ALIs.Table (Id).Restrictions.Violated (RP) := True;
Cumulative_Restrictions.Violated (RP) := True;
Checkc (' ');
declare
N : constant Integer := Integer (Get_Nat);
pragma Unsuppress (Overflow_Check);
-- Acquire information for parameter restrictions
begin
ALIs.Table (Id).Restrictions.Count (RP) := N;
for RP in All_Parameter_Restrictions loop
if RP in Checked_Max_Parameter_Restrictions then
Cumulative_Restrictions.Count (RP) :=
Integer'Max (Cumulative_Restrictions.Count (RP), N);
else
Cumulative_Restrictions.Count (RP) :=
Cumulative_Restrictions.Count (RP) + N;
end if;
-- Acquire restrictions pragma information
exception
when Constraint_Error =>
case Getc is
when 'n' =>
null;
-- 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.
when 'r' =>
ALIs.Table (Id).Restrictions.Set (RP) := True;
Cumulative_Restrictions.Value (RP) := Integer'Last;
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;
when others =>
Fatal_Error;
end case;
-- Acquire restrictions violations information
case Getc is
when 'n' =>
null;
when 'v' =>
ALIs.Table (Id).Restrictions.Violated (RP) := True;
Cumulative_Restrictions.Violated (RP) := True;
declare
N : constant Integer := Integer (Get_Nat);
pragma Unsuppress (Overflow_Check);
begin
ALIs.Table (Id).Restrictions.Count (RP) := N;
if RP in Checked_Max_Parameter_Restrictions then
Cumulative_Restrictions.Count (RP) :=
Integer'Max
(Cumulative_Restrictions.Count (RP), N);
else
Cumulative_Restrictions.Count (RP) :=
Cumulative_Restrictions.Count (RP) + N;
end if;
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.
Cumulative_Restrictions.Value (RP) := Integer'Last;
Cumulative_Restrictions.Unknown (RP) := True;
end;
if Nextc = '+' then
Skipc;
ALIs.Table (Id).Restrictions.Unknown (RP) := True;
Cumulative_Restrictions.Unknown (RP) := True;
end;
end if;
if Nextc = '+' then
Skipc;
ALIs.Table (Id).Restrictions.Unknown (RP) := True;
Cumulative_Restrictions.Unknown (RP) := True;
end if;
when others =>
Fatal_Error;
end case;
end loop;
when others =>
Skip_Eol;
-- Here if error during scanning of restrictions line
exception
when Bad_R_Line =>
-- In Ignore_Errors mode, undo any changes to restrictions
-- from this unit, and continue on.
if Ignore_Errors then
Cumulative_Restrictions := Save_R;
ALIs.Table (Id).Restrictions := Restrictions_Initial;
-- In normal mode, this is a fatal error
else
Fatal_Error;
end case;
end loop;
end if;
Skip_Eol;
C := Getc;
end Scan_Restrictions;
end if;
-- Acquire 'I' lines if present
C := Getc;
Check_Unknown_Line;
while C = 'I' loop
if Ignore ('I') then
Skip_Line;
@ -983,7 +1134,9 @@ package body ALI is
-- Loop to acquire unit entries
Unit_Loop : while C = 'U' loop
U_Loop : loop
Check_Unknown_Line;
exit U_Loop when C /= 'U';
-- Note: as per spec, we never ignore U lines
@ -1104,17 +1257,28 @@ package body ALI is
-- BN parameter (Body needed)
elsif C = 'B' then
Checkc ('N');
Check_At_End_Of_Field;
Units.Table (Units.Last).Body_Needed_For_SAL := True;
C := Getc;
-- DE parameter (Dynamic elaboration checks
if C = 'N' then
Check_At_End_Of_Field;
Units.Table (Units.Last).Body_Needed_For_SAL := True;
else
Fatal_Error_Ignore;
end if;
-- DE parameter (Dynamic elaboration checks)
elsif C = 'D' then
Checkc ('E');
Check_At_End_Of_Field;
Units.Table (Units.Last).Dynamic_Elab := True;
Dynamic_Elaboration_Checks_Specified := True;
C := Getc;
if C = 'E' then
Check_At_End_Of_Field;
Units.Table (Units.Last).Dynamic_Elab := True;
Dynamic_Elaboration_Checks_Specified := True;
else
Fatal_Error_Ignore;
end if;
-- EB/EE parameters
@ -1123,12 +1287,10 @@ package body ALI is
if C = 'B' then
Units.Table (Units.Last).Elaborate_Body := True;
elsif C = 'E' then
Units.Table (Units.Last).Set_Elab_Entity := True;
else
Fatal_Error;
Fatal_Error_Ignore;
end if;
Check_At_End_Of_Field;
@ -1136,9 +1298,14 @@ package body ALI is
-- GE parameter (generic)
elsif C = 'G' then
Checkc ('E');
Check_At_End_Of_Field;
Units.Table (Units.Last).Is_Generic := True;
C := Getc;
if C = 'E' then
Check_At_End_Of_Field;
Units.Table (Units.Last).Is_Generic := True;
else
Fatal_Error_Ignore;
end if;
-- IL/IS/IU parameters
@ -1147,16 +1314,13 @@ package body ALI is
if C = 'L' then
Units.Table (Units.Last).Icasing := All_Lower_Case;
elsif C = 'S' then
Units.Table (Units.Last).Init_Scalars := True;
Initialize_Scalars_Used := True;
elsif C = 'U' then
Units.Table (Units.Last).Icasing := All_Upper_Case;
else
Fatal_Error;
Fatal_Error_Ignore;
end if;
Check_At_End_Of_Field;
@ -1168,12 +1332,10 @@ package body ALI is
if C = 'M' then
Units.Table (Units.Last).Kcasing := Mixed_Case;
elsif C = 'U' then
Units.Table (Units.Last).Kcasing := All_Upper_Case;
else
Fatal_Error;
Fatal_Error_Ignore;
end if;
Check_At_End_Of_Field;
@ -1181,32 +1343,29 @@ package body ALI is
-- NE parameter
elsif C = 'N' then
Checkc ('E');
Units.Table (Units.Last).No_Elab := True;
Check_At_End_Of_Field;
C := Getc;
if C = 'E' then
Units.Table (Units.Last).No_Elab := True;
Check_At_End_Of_Field;
else
Fatal_Error_Ignore;
end if;
-- PR/PU/PK parameters
elsif C = 'P' then
C := Getc;
-- PR parameter (preelaborate)
if C = 'R' then
Units.Table (Units.Last).Preelab := True;
-- PU parameter (pure)
elsif C = 'U' then
Units.Table (Units.Last).Pure := True;
-- PK indicates unit is package
elsif C = 'K' then
Units.Table (Units.Last).Unit_Kind := 'p';
else
Fatal_Error;
Fatal_Error_Ignore;
end if;
Check_At_End_Of_Field;
@ -1216,23 +1375,14 @@ package body ALI is
elsif C = 'R' then
C := Getc;
-- RC parameter (remote call interface)
if C = 'C' then
Units.Table (Units.Last).RCI := True;
-- RT parameter (remote types)
elsif C = 'T' then
Units.Table (Units.Last).Remote_Types := True;
-- RA parameter (remote access to class wide type)
elsif C = 'A' then
Units.Table (Units.Last).Has_RACW := True;
else
Fatal_Error;
Fatal_Error_Ignore;
end if;
Check_At_End_Of_Field;
@ -1240,24 +1390,19 @@ package body ALI is
elsif C = 'S' then
C := Getc;
-- SP parameter (shared passive)
if C = 'P' then
Units.Table (Units.Last).Shared_Passive := True;
-- SU parameter indicates unit is subprogram
elsif C = 'U' then
Units.Table (Units.Last).Unit_Kind := 's';
else
Fatal_Error;
Fatal_Error_Ignore;
end if;
Check_At_End_Of_Field;
else
Fatal_Error;
C := Getc;
Fatal_Error_Ignore;
end if;
end loop;
@ -1275,7 +1420,10 @@ package body ALI is
-- Scan out With lines for this unit
With_Loop : while C = 'W' loop
With_Loop : loop
Check_Unknown_Line;
exit With_Loop when C /= 'W';
if Ignore ('W') then
Skip_Line;
@ -1345,7 +1493,9 @@ package body ALI is
Name_Len := 0;
Linker_Options_Loop : while C = 'L' loop
Linker_Options_Loop : loop
Check_Unknown_Line;
exit Linker_Options_Loop when C /= 'L';
if Ignore ('L') then
Skip_Line;
@ -1361,7 +1511,7 @@ package body ALI is
if C < Character'Val (16#20#)
or else C > Character'Val (16#7E#)
then
Fatal_Error;
Fatal_Error_Ignore;
elsif C = '{' then
C := Character'Val (0);
@ -1386,7 +1536,7 @@ package body ALI is
10;
else
Fatal_Error;
Fatal_Error_Ignore;
end if;
end loop;
@ -1428,7 +1578,7 @@ package body ALI is
Linker_Options.Table (Linker_Options.Last).Original_Pos :=
Linker_Options.Last;
end if;
end loop Unit_Loop;
end loop U_Loop;
-- End loop through units for one ALI file
@ -1457,7 +1607,10 @@ package body ALI is
-- Scan out external version references and put in hash table
while C = 'E' loop
E_Loop : loop
Check_Unknown_Line;
exit E_Loop when C /= 'E';
if Ignore ('E') then
Skip_Line;
@ -1483,13 +1636,16 @@ package body ALI is
end if;
C := Getc;
end loop;
end loop E_Loop;
-- Scan out source dependency lines for this ALI file
ALIs.Table (Id).First_Sdep := Sdep.Last + 1;
while C = 'D' loop
D_Loop : loop
Check_Unknown_Line;
exit D_Loop when C /= 'D';
if Ignore ('D') then
Skip_Line;
@ -1585,13 +1741,19 @@ package body ALI is
end if;
C := Getc;
end loop;
end loop D_Loop;
ALIs.Table (Id).Last_Sdep := Sdep.Last;
-- We must at this stage be at an Xref line or the end of file
if C /= EOF and then C /= 'X' then
if C = EOF then
return Id;
end if;
Check_Unknown_Line;
if C /= 'X' then
Fatal_Error;
end if;
@ -1604,7 +1766,9 @@ package body ALI is
-- Loop through Xref sections
while C = 'X' loop
X_Loop : loop
Check_Unknown_Line;
exit X_Loop when C /= 'X';
-- Make new entry in section table
@ -1864,7 +2028,7 @@ package body ALI is
end Read_Refs_For_One_File;
C := Getc;
end loop;
end loop X_Loop;
-- Here after dealing with xref sections

22
gcc/ada/ali.ads
View File

@ -808,13 +808,14 @@ package ALI is
-- Initialize the ALI tables. Also resets all switch values to defaults.
function Scan_ALI
(F : File_Name_Type;
T : Text_Buffer_Ptr;
Ignore_ED : Boolean;
Err : Boolean;
Read_Xref : Boolean := False;
Read_Lines : String := "";
Ignore_Lines : String := "X") return ALI_Id;
(F : File_Name_Type;
T : Text_Buffer_Ptr;
Ignore_ED : Boolean;
Err : Boolean;
Read_Xref : Boolean := False;
Read_Lines : String := "";
Ignore_Lines : String := "X";
Ignore_Errors : Boolean := False) return ALI_Id;
-- Given the text, T, of an ALI file, F, scan and store the information
-- from the file, and return the Id of the resulting entry in the ALI
-- table. Switch settings may be modified as described above in the
@ -854,5 +855,12 @@ package ALI is
-- Ignore_Lines and Read_Lines parameters are ignored (i.e. the
-- use of True for Read_XREF is equivalent to specifying an
-- argument of "UWDX" for Read_Lines.
--
-- Ignore_Errors is normally False. If it is set True, then Scan_ALI
-- will do its best to scan through a file and extract all information
-- it can, even if there are errors. In this case Err is only set if
-- Scan_ALI was completely unable to process the file (e.g. it did not
-- look like an ALI file at all). Ignore_Errors is intended to improve
-- the downward compatibility of new compilers with old tools.
end ALI;

61
gcc/ada/bcheck.adb
View File

@ -424,7 +424,7 @@ package body Bcheck is
if not Restriction_File_Output then
Restriction_File_Output := True;
-- Find the ali file specifying the restriction
-- Find an ali file specifying the restriction
for A in ALIs.First .. ALIs.Last loop
if ALIs.Table (A).Restrictions.Set (R)
@ -463,6 +463,7 @@ package body Bcheck is
Consistency_Error_Msg (M2 (1 .. P - 1));
Consistency_Error_Msg
("but the following files violate this restriction:");
return;
end;
end if;
end loop;
@ -491,38 +492,50 @@ package body Bcheck is
-- Loop through files looking for violators
for A2 in ALIs.First .. ALIs.Last loop
if ALIs.Table (A2).Restrictions.Violated (R) then
declare
T : ALIs_Record renames ALIs.Table (A2);
-- We exclude predefined files from the list of
-- violators. This should be rethought. It is not
-- clear that this is the right thing to do, that
-- is particularly the case for restricted runtimes.
begin
if T.Restrictions.Violated (R) then
if not Is_Internal_File_Name (ALIs.Table (A2).Sfile) then
Print_Restriction_File (R);
-- We exclude predefined files from the list of
-- violators. This should be rethought. It is not
-- clear that this is the right thing to do, that
-- is particularly the case for restricted runtimes.
Error_Msg_Name_1 := ALIs.Table (A2).Sfile;
if not Is_Internal_File_Name (T.Sfile) then
if R in All_Boolean_Restrictions then
Consistency_Error_Msg (" %");
-- Case of Boolean restriction, just print file name
elsif R in Checked_Add_Parameter_Restrictions
or else ALIs.Table (A2).Restrictions.Count (R) >
Cumulative_Restrictions.Value (R)
then
Error_Msg_Nat_1 :=
Int (ALIs.Table (A2).Restrictions.Count (R));
if R in All_Boolean_Restrictions then
Print_Restriction_File (R);
Error_Msg_Name_1 := T.Sfile;
Consistency_Error_Msg (" %");
if ALIs.Table (A2).Restrictions.Unknown (R) then
Consistency_Error_Msg
(" % (count = at least #)");
else
Consistency_Error_Msg
(" % (count = #)");
-- Case of Parameter restriction where violation
-- count exceeds restriction value, print file
-- name and count, adding "at least" if the
-- exact count is not known.
elsif R in Checked_Add_Parameter_Restrictions
or else T.Restrictions.Count (R) >
Cumulative_Restrictions.Value (R)
then
Print_Restriction_File (R);
Error_Msg_Name_1 := T.Sfile;
Error_Msg_Nat_1 := Int (T.Restrictions.Count (R));
if T.Restrictions.Unknown (R) then
Consistency_Error_Msg
(" % (count = at least #)");
else
Consistency_Error_Msg
(" % (count = #)");
end if;
end if;
end if;
end if;
end if;
end;
end loop;
end if;
end loop;

11
gcc/ada/debug.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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- --
@ -142,7 +142,7 @@ package body Debug is
-- df
-- dg
-- dh
-- di
-- di Ignore_Errors mode for reading ali files
-- dj
-- dk
-- dl
@ -474,7 +474,6 @@ package body Debug is
-- fully compiled and analyzed, they just get eliminated from the
-- code generation step.
-- d1 Error messages have node numbers where possible. Normally error
-- messages have only source locations. This option is useful when
-- debugging errors caused by expanded code, where the source location
@ -528,6 +527,12 @@ package body Debug is
-- dependencies) except that internal units are included in the
-- listing.
-- di Normally gnatbind calls Read_Ali with Ignore_Errors set to
-- False, since the binder really needs correct version ALI
-- files to do its job. This debug flag causes Ignore_Errors
-- mode to be set for the binder (and is particularly useful
-- for testing ignore errors mode).
-- dn List details of manipulation of Num_Pred values during execution of
-- the algorithm used to determine a correct order of elaboration. This
-- is useful in diagnosing any problems in its behavior.

36
gcc/ada/errout.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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- --
@ -164,10 +164,9 @@ package body Errout is
-- example, the entity A.B.C.D will output B.C. if N = 2.
function Special_Msg_Delete
(Msg : String;
N : Node_Or_Entity_Id;
E : Node_Or_Entity_Id)
return Boolean;
(Msg : String;
N : Node_Or_Entity_Id;
E : Node_Or_Entity_Id) return Boolean;
-- This function is called from Error_Msg_NEL, passing the message Msg,
-- node N on which the error is to be posted, and the entity or node E
-- to be used for an & insertion in the message if any. The job of this
@ -1795,6 +1794,8 @@ package body Errout is
----------------------------
procedure Set_Msg_Insertion_Node is
K : Node_Kind;
begin
Suppress_Message :=
Error_Msg_Node_1 = Error
@ -1815,11 +1816,25 @@ package body Errout is
else
Set_Msg_Blank_Conditional;
-- Skip quotes for operator case
-- Output name
if Nkind (Error_Msg_Node_1) in N_Op then
K := Nkind (Error_Msg_Node_1);
-- If we have operator case, skip quotes since name of operator
-- itself will supply the required quotations. An operator can be
-- an applied use in an expression or an explicit operator symbol,
-- or an identifier whose name indicates it is an operator.
if K in N_Op
or else K = N_Operator_Symbol
or else K = N_Defining_Operator_Symbol
or else ((K = N_Identifier or else K = N_Defining_Identifier)
and then Is_Operator_Name (Chars (Error_Msg_Node_1)))
then
Set_Msg_Node (Error_Msg_Node_1);
-- Normal case, not an operator, surround with quotes
else
Set_Msg_Quote;
Set_Qualification (Error_Msg_Qual_Level, Error_Msg_Node_1);
@ -2302,10 +2317,9 @@ package body Errout is
------------------------
function Special_Msg_Delete
(Msg : String;
N : Node_Or_Entity_Id;
E : Node_Or_Entity_Id)
return Boolean
(Msg : String;
N : Node_Or_Entity_Id;
E : Node_Or_Entity_Id) return Boolean
is
begin
-- Never delete messages in -gnatdO mode

77
gcc/ada/exp_ch3.adb
View File

@ -90,8 +90,7 @@ package body Exp_Ch3 is
function Build_Discriminant_Formals
(Rec_Id : Entity_Id;
Use_Dl : Boolean)
return List_Id;
Use_Dl : Boolean) return List_Id;
-- This function uses the discriminants of a type to build a list of
-- formal parameters, used in the following function. If the flag Use_Dl
-- is set, the list is built using the already defined discriminals
@ -246,8 +245,7 @@ package body Exp_Ch3 is
Name : Name_Id;
Profile : List_Id;
Ret_Type : Entity_Id := Empty;
For_Body : Boolean := False)
return Node_Id;
For_Body : Boolean := False) return Node_Id;
-- This function generates the appropriate expansion for a predefined
-- primitive operation specified by its name, parameter profile and
-- return type (Empty means this is a procedure). If For_Body is false,
@ -259,8 +257,7 @@ package body Exp_Ch3 is
(Loc : Source_Ptr;
Tag_Typ : Entity_Id;
Name : TSS_Name_Type;
For_Body : Boolean := False)
return Node_Id;
For_Body : Boolean := False) return Node_Id;
-- Specialized version of Predef_Spec_Or_Body that apply to read, write,
-- input and output attribute whose specs are constructed in Exp_Strm.
@ -268,15 +265,13 @@ package body Exp_Ch3 is
(Loc : Source_Ptr;
Tag_Typ : Entity_Id;
Name : TSS_Name_Type;
For_Body : Boolean := False)
return Node_Id;
For_Body : Boolean := False) return Node_Id;
-- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust
-- and _deep_finalize
function Predefined_Primitive_Bodies
(Tag_Typ : Entity_Id;
Renamed_Eq : Node_Id)
return List_Id;
Renamed_Eq : Node_Id) return List_Id;
-- Create the bodies of the predefined primitives that are described in
-- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote
-- the defining unit name of the type's predefined equality as returned
@ -721,8 +716,7 @@ package body Exp_Ch3 is
function Build_Case_Statement
(Case_Id : Entity_Id;
Variant : Node_Id)
return Node_Id;
Variant : Node_Id) return Node_Id;
-- Build a case statement containing only two alternatives. The
-- first alternative corresponds exactly to the discrete choices
-- given on the variant with contains the components that we are
@ -732,8 +726,7 @@ package body Exp_Ch3 is
function Build_Dcheck_Function
(Case_Id : Entity_Id;
Variant : Node_Id)
return Entity_Id;
Variant : Node_Id) return Entity_Id;
-- Build the discriminant checking function for a given variant
procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id);
@ -746,8 +739,7 @@ package body Exp_Ch3 is
function Build_Case_Statement
(Case_Id : Entity_Id;
Variant : Node_Id)
return Node_Id
Variant : Node_Id) return Node_Id
is
Alt_List : constant List_Id := New_List;
Actuals_List : List_Id;
@ -834,8 +826,7 @@ package body Exp_Ch3 is
function Build_Dcheck_Function
(Case_Id : Entity_Id;
Variant : Node_Id)
return Entity_Id
Variant : Node_Id) return Entity_Id
is
Body_Node : Node_Id;
Func_Id : Entity_Id;
@ -972,8 +963,7 @@ package body Exp_Ch3 is
function Build_Discriminant_Formals
(Rec_Id : Entity_Id;
Use_Dl : Boolean)
return List_Id
Use_Dl : Boolean) return List_Id
is
Loc : Source_Ptr := Sloc (Rec_Id);
Parameter_List : constant List_Id := New_List;
@ -1046,8 +1036,7 @@ package body Exp_Ch3 is
In_Init_Proc : Boolean := False;
Enclos_Type : Entity_Id := Empty;
Discr_Map : Elist_Id := New_Elmt_List;
With_Default_Init : Boolean := False)
return List_Id
With_Default_Init : Boolean := False) return List_Id
is
First_Arg : Node_Id;
Args : List_Id;
@ -1374,9 +1363,7 @@ package body Exp_Ch3 is
-- components of the given component list. This may involve building
-- case statements for the variant parts.
function Build_Init_Call_Thru
(Parameters : List_Id)
return List_Id;
function Build_Init_Call_Thru (Parameters : List_Id) return List_Id;
-- Given a non-tagged type-derivation that declares discriminants,
-- such as
--
@ -1404,8 +1391,7 @@ package body Exp_Ch3 is
-- to which the check actions are appended.
function Component_Needs_Simple_Initialization
(T : Entity_Id)
return Boolean;
(T : Entity_Id) return Boolean;
-- Determines if a component needs simple initialization, given its
-- type T. This is the same as Needs_Simple_Initialization except
-- for the following differences. The types Tag and Vtable_Ptr,
@ -1597,18 +1583,15 @@ package body Exp_Ch3 is
-- Build_Init_Call_Thru --
--------------------------
function Build_Init_Call_Thru
(Parameters : List_Id)
return List_Id
is
Parent_Proc : constant Entity_Id :=
Base_Init_Proc (Etype (Rec_Type));
function Build_Init_Call_Thru (Parameters : List_Id) return List_Id is
Parent_Proc : constant Entity_Id :=
Base_Init_Proc (Etype (Rec_Type));
Parent_Type : constant Entity_Id :=
Etype (First_Formal (Parent_Proc));
Parent_Type : constant Entity_Id :=
Etype (First_Formal (Parent_Proc));
Uparent_Type : constant Entity_Id :=
Underlying_Type (Parent_Type);
Uparent_Type : constant Entity_Id :=
Underlying_Type (Parent_Type);
First_Discr_Param : Node_Id;
@ -2184,8 +2167,7 @@ package body Exp_Ch3 is
-------------------------------------------
function Component_Needs_Simple_Initialization
(T : Entity_Id)
return Boolean
(T : Entity_Id) return Boolean
is
begin
return
@ -4755,9 +4737,8 @@ package body Exp_Ch3 is
-------------------------
function Get_Simple_Init_Val
(T : Entity_Id;
Loc : Source_Ptr)
return Node_Id
(T : Entity_Id;
Loc : Source_Ptr) return Node_Id
is
Val : Node_Id;
Typ : Node_Id;
@ -5478,8 +5459,7 @@ package body Exp_Ch3 is
(Loc : Source_Ptr;
Tag_Typ : Entity_Id;
Name : TSS_Name_Type;
For_Body : Boolean := False)
return Node_Id
For_Body : Boolean := False) return Node_Id
is
Prof : List_Id;
Type_B : Entity_Id;
@ -5533,8 +5513,7 @@ package body Exp_Ch3 is
Name : Name_Id;
Profile : List_Id;
Ret_Type : Entity_Id := Empty;
For_Body : Boolean := False)
return Node_Id
For_Body : Boolean := False) return Node_Id
is
Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name);
Spec : Node_Id;
@ -5604,8 +5583,7 @@ package body Exp_Ch3 is
(Loc : Source_Ptr;
Tag_Typ : Entity_Id;
Name : TSS_Name_Type;
For_Body : Boolean := False)
return Node_Id
For_Body : Boolean := False) return Node_Id
is
Ret_Type : Entity_Id;
@ -5630,8 +5608,7 @@ package body Exp_Ch3 is
function Predefined_Primitive_Bodies
(Tag_Typ : Entity_Id;
Renamed_Eq : Node_Id)
return List_Id
Renamed_Eq : Node_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (Tag_Typ);
Res : constant List_Id := New_List;

103
gcc/ada/exp_ch4.adb
View File

@ -98,8 +98,7 @@ package body Exp_Ch4 is
A_Typ : Entity_Id;
Lhs : Node_Id;
Rhs : Node_Id;
Bodies : List_Id)
return Node_Id;
Bodies : List_Id) return Node_Id;
-- Expand an array equality into a call to a function implementing this
-- equality, and a call to it. Loc is the location for the generated
-- nodes. Typ is the type of the array, and Lhs, Rhs are the array
@ -119,8 +118,7 @@ package body Exp_Ch4 is
Typ : Entity_Id;
Lhs : Node_Id;
Rhs : Node_Id;
Bodies : List_Id)
return Node_Id;
Bodies : List_Id) return Node_Id;
-- Local recursive function used to expand equality for nested
-- composite types. Used by Expand_Record/Array_Equality, Bodies
-- is a list on which to attach bodies of local functions that are
@ -150,8 +148,7 @@ package body Exp_Ch4 is
function Get_Allocator_Final_List
(N : Node_Id;
T : Entity_Id;
PtrT : Entity_Id)
return Entity_Id;
PtrT : Entity_Id) return Entity_Id;
-- If the designated type is controlled, build final_list expression
-- for created object. If context is an access parameter, create a
-- local access type to have a usable finalization list.
@ -161,9 +158,8 @@ package body Exp_Ch4 is
-- from Checked_Pool, expands a call to the primitive 'dereference'.
function Make_Array_Comparison_Op
(Typ : Entity_Id;
Nod : Node_Id)
return Node_Id;
(Typ : Entity_Id;
Nod : Node_Id) return Node_Id;
-- Comparisons between arrays are expanded in line. This function
-- produces the body of the implementation of (a > b), where a and b
-- are one-dimensional arrays of some discrete type. The original
@ -171,9 +167,8 @@ package body Exp_Ch4 is
-- Nod provides the Sloc value for the generated code.
function Make_Boolean_Array_Op
(Typ : Entity_Id;
N : Node_Id)
return Node_Id;
(Typ : Entity_Id;
N : Node_Id) return Node_Id;
-- Boolean operations on boolean arrays are expanded in line. This
-- function produce the body for the node N, which is (a and b),
-- (a or b), or (a xor b). It is used only the normal case and not
@ -193,10 +188,9 @@ package body Exp_Ch4 is
-- Deals with a second operand being (or not) a class-wide type.
function Safe_In_Place_Array_Op
(Lhs : Node_Id;
Op1 : Node_Id;
Op2 : Node_Id)
return Boolean;
(Lhs : Node_Id;
Op1 : Node_Id;
Op2 : Node_Id) return Boolean;
-- In the context of an assignment, where the right-hand side is a
-- boolean operation on arrays, check whether operation can be performed
-- in place.
@ -913,8 +907,7 @@ package body Exp_Ch4 is
A_Typ : Entity_Id;
Lhs : Node_Id;
Rhs : Node_Id;
Bodies : List_Id)
return Node_Id
Bodies : List_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Nod);
Decls : constant List_Id := New_List;
@ -932,8 +925,7 @@ package body Exp_Ch4 is
function Arr_Attr
(Arr : Entity_Id;
Nam : Name_Id;
Num : Int)
return Node_Id;
Num : Int) return Node_Id;
-- This builds the attribute reference Arr'Nam (Expr).
function Component_Equality (Typ : Entity_Id) return Node_Id;
@ -942,8 +934,7 @@ package body Exp_Ch4 is
function Handle_One_Dimension
(N : Int;
Index : Node_Id)
return Node_Id;
Index : Node_Id) return Node_Id;
-- This procedure returns a declare block:
--
-- declare
@ -990,8 +981,7 @@ package body Exp_Ch4 is
function Arr_Attr
(Arr : Entity_Id;
Nam : Name_Id;
Num : Int)
return Node_Id
Num : Int) return Node_Id
is
begin
return
@ -1039,8 +1029,7 @@ package body Exp_Ch4 is
function Handle_One_Dimension
(N : Int;
Index : Node_Id)
return Node_Id
Index : Node_Id) return Node_Id
is
An : constant Entity_Id := Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('A'));
@ -1337,8 +1326,7 @@ package body Exp_Ch4 is
Typ : Entity_Id;
Lhs : Node_Id;
Rhs : Node_Id;
Bodies : List_Id)
return Node_Id
Bodies : List_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Nod);
Full_Type : Entity_Id;
@ -2841,10 +2829,9 @@ package body Exp_Ch4 is
Check_Subscripts : declare
function Construct_Attribute_Reference
(E : Node_Id;
Nam : Name_Id;
Dim : Nat)
return Node_Id;
(E : Node_Id;
Nam : Name_Id;
Dim : Nat) return Node_Id;
-- Build attribute reference E'Nam(Dim)
-----------------------------------
@ -2852,10 +2839,9 @@ package body Exp_Ch4 is
-----------------------------------
function Construct_Attribute_Reference
(E : Node_Id;
Nam : Name_Id;
Dim : Nat)
return Node_Id
(E : Node_Id;
Nam : Name_Id;
Dim : Nat) return Node_Id
is
begin
return
@ -3710,13 +3696,23 @@ package body Exp_Ch4 is
and then Is_Derived_Type (A_Typ)
and then No (Full_View (A_Typ))
then
-- Search for equality operation, checking that the
-- operands have the same type. Note that we must find
-- a matching entry, or something is very wrong!
Prim := First_Elmt (Collect_Primitive_Operations (A_Typ));
while Chars (Node (Prim)) /= Name_Op_Eq loop
while Present (Prim) loop
exit when Chars (Node (Prim)) = Name_Op_Eq
and then Etype (First_Formal (Node (Prim))) =
Etype (Next_Formal (First_Formal (Node (Prim))))
and then
Base_Type (Etype (Node (Prim))) = Standard_Boolean;
Next_Elmt (Prim);
pragma Assert (Present (Prim));
end loop;
pragma Assert (Present (Prim));
Op_Name := Node (Prim);
-- Find the type's predefined equality or an overriding
@ -3741,9 +3737,9 @@ package body Exp_Ch4 is
Base_Type (Etype (Node (Prim))) = Standard_Boolean;
Next_Elmt (Prim);
pragma Assert (Present (Prim));
end loop;
pragma Assert (Present (Prim));
Op_Name := Node (Prim);
end if;
@ -6340,8 +6336,7 @@ package body Exp_Ch4 is
Typ : Entity_Id;
Lhs : Node_Id;
Rhs : Node_Id;
Bodies : List_Id)
return Node_Id
Bodies : List_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Nod);
@ -6496,8 +6491,7 @@ package body Exp_Ch4 is
function Get_Allocator_Final_List
(N : Node_Id;
T : Entity_Id;
PtrT : Entity_Id)
return Entity_Id
PtrT : Entity_Id) return Entity_Id
is
Loc : constant Source_Ptr := Sloc (N);
Acc : Entity_Id;
@ -6540,7 +6534,11 @@ package body Exp_Ch4 is
Pool : constant Entity_Id := Associated_Storage_Pool (Typ);
function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
-- return true if type of P is derived from Checked_Pool;
-- Return true if type of P is derived from Checked_Pool;
-----------------------------
-- Is_Checked_Storage_Pool --
-----------------------------
function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
T : Entity_Id;
@ -6662,9 +6660,8 @@ package body Exp_Ch4 is
-- instantiated function itself.
function Make_Array_Comparison_Op
(Typ : Entity_Id;
Nod : Node_Id)
return Node_Id
(Typ : Entity_Id;
Nod : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Nod);
@ -6897,9 +6894,8 @@ package body Exp_Ch4 is
-- Here typ is the boolean array type
function Make_Boolean_Array_Op
(Typ : Entity_Id;
N : Node_Id)
return Node_Id
(Typ : Entity_Id;
N : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
@ -7069,10 +7065,9 @@ package body Exp_Ch4 is
----------------------------
function Safe_In_Place_Array_Op
(Lhs : Node_Id;
Op1 : Node_Id;
Op2 : Node_Id)
return Boolean
(Lhs : Node_Id;
Op1 : Node_Id;
Op2 : Node_Id) return Boolean
is
Target : Entity_Id;

4
gcc/ada/exp_ch6.adb
View File

@ -596,6 +596,10 @@ package body Exp_Ch6 is
Init :=
Convert_To (Etype (Formal), New_Occurrence_Of (Var, Loc));
end if;
elsif Ekind (Formal) = E_In_Parameter then
Init := New_Occurrence_Of (Var, Loc);
else
Init := Empty;
end if;

2
gcc/ada/exp_ch9.adb
View File

@ -3369,7 +3369,7 @@ package body Exp_Ch9 is
Set_Scope (Func, Scope (Prot));
else
Analyze (Cond);
Analyze_And_Resolve (Cond, Any_Boolean);
end if;
-- The Ravenscar profile restricts barriers to simple variables

19
gcc/ada/gnatbind.adb
View File

@ -34,6 +34,7 @@ with Bindusg;
with Butil; use Butil;
with Casing; use Casing;
with Csets;
with Debug; use Debug;
with Fmap;
with Gnatvsn; use Gnatvsn;
with Namet; use Namet;
@ -532,10 +533,11 @@ begin
begin
Id := Scan_ALI
(F => Main_Lib_File,
T => Text,
Ignore_ED => Force_RM_Elaboration_Order,
Err => False);
(F => Main_Lib_File,
T => Text,
Ignore_ED => Force_RM_Elaboration_Order,
Err => False,
Ignore_Errors => Debug_Flag_I);
end;
Free (Text);
@ -576,10 +578,11 @@ begin
begin
Id :=
Scan_ALI
(F => Std_Lib_File,
T => Text,
Ignore_ED => Force_RM_Elaboration_Order,
Err => False);
(F => Std_Lib_File,
T => Text,
Ignore_ED => Force_RM_Elaboration_Order,
Err => False,
Ignore_Errors => Debug_Flag_I);
end;
Free (Text);

12
gcc/ada/gnatlink.adb
View File

@ -1409,9 +1409,17 @@ begin
T := Read_Library_Info (F, True);
-- Read it
-- Read it. Note that we ignore errors, since we only want very
-- limited information from the ali file, and likely a slightly
-- wrong version will be just fine, though in normal operation
-- we don't expect this to happen!
A := Scan_ALI (F, T, Ignore_ED => False, Err => False);
A := Scan_ALI
(F,
T,
Ignore_ED => False,
Err => False,
Ignore_Errors => True);
if A /= No_ALI_Id then
for

6
gcc/ada/gnatls.adb
View File

@ -943,7 +943,11 @@ begin
begin
Discard :=
Scan_ALI
(Ali_File, Text, Ignore_ED => False, Err => False);
(Ali_File,
Text,
Ignore_ED => False,
Err => False,
Ignore_Errors => True);
end;
Free (Text);

28
gcc/ada/lib-load.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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- --
@ -55,8 +55,7 @@ package body Lib.Load is
function Spec_Is_Irrelevant
(Spec_Unit : Unit_Number_Type;
Body_Unit : Unit_Number_Type)
return Boolean;
Body_Unit : Unit_Number_Type) return Boolean;
-- The Spec_Unit and Body_Unit parameters are the unit numbers of the
-- spec file that corresponds to the main unit which is a body. This
-- function determines if the spec file is irrelevant and will be
@ -73,8 +72,7 @@ package body Lib.Load is
function Create_Dummy_Package_Unit
(With_Node : Node_Id;
Spec_Name : Unit_Name_Type)
return Unit_Number_Type
Spec_Name : Unit_Name_Type) return Unit_Number_Type
is
Unum : Unit_Number_Type;
Cunit_Entity : Entity_Id;
@ -100,9 +98,6 @@ package body Lib.Load is
-- Child package
else
-- Nkind (Name (With_Node)) = N_Expanded_Name
Cunit_Entity :=
Make_Defining_Identifier (No_Location,
Chars => Chars (Selector_Name (Name (With_Node))));
@ -117,7 +112,6 @@ package body Lib.Load is
Make_Designator (No_Location,
Name => New_Copy_Tree (Prefix (Name (With_Node))),
Identifier => New_Occurrence_Of (Cunit_Entity, No_Location));
end if;
Set_Scope (Cunit_Entity, Standard_Standard);
@ -213,7 +207,6 @@ package body Lib.Load is
Units.Table (Main_Unit).Unit_File_Name := Fname;
if Fname /= No_File then
Main_Source_File := Load_Source_File (Fname);
Current_Error_Source_File := Main_Source_File;
@ -249,8 +242,7 @@ package body Lib.Load is
Error_Node : Node_Id;
Subunit : Boolean;
Corr_Body : Unit_Number_Type := No_Unit;
Renamings : Boolean := False)
return Unit_Number_Type
Renamings : Boolean := False) return Unit_Number_Type
is
Calling_Unit : Unit_Number_Type;
Uname_Actual : Unit_Name_Type;
@ -340,14 +332,14 @@ package body Lib.Load is
Par := Prefix (Par);
end loop;
if Nkind (Par) = N_Selected_Component then
-- some intermediate parent is a renaming.
-- Case of some intermediate parent is a renaming
if Nkind (Par) = N_Selected_Component then
Set_Entity (Selector_Name (Par), Cunit_Entity (Unump));
else
-- the ultimate parent is a renaming.
-- Case where the ultimate parent is a renaming
else
Set_Entity (Par, Cunit_Entity (Unump));
end if;
end;
@ -705,11 +697,11 @@ package body Lib.Load is
function Spec_Is_Irrelevant
(Spec_Unit : Unit_Number_Type;
Body_Unit : Unit_Number_Type)
return Boolean
Body_Unit : Unit_Number_Type) return Boolean
is
Sunit : constant Node_Id := Cunit (Spec_Unit);
Bunit : constant Node_Id := Cunit (Body_Unit);
begin
-- The spec is irrelevant if the body is a subprogram body, and the
-- spec is other than a subprogram spec or generic subprogram spec.

8
gcc/ada/lib-load.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, 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- --
@ -109,8 +109,7 @@ package Lib.Load is
Error_Node : Node_Id;
Subunit : Boolean;
Corr_Body : Unit_Number_Type := No_Unit;
Renamings : Boolean := False)
return Unit_Number_Type;
Renamings : Boolean := False) return Unit_Number_Type;
-- This function loads and parses the unit specified by Load_Name (or
-- returns the unit number for the previously constructed units table
-- entry if this is not the first call for this unit). Required indicates
@ -151,8 +150,7 @@ package Lib.Load is
function Create_Dummy_Package_Unit
(With_Node : Node_Id;
Spec_Name : Unit_Name_Type)
return Unit_Number_Type;
Spec_Name : Unit_Name_Type) return Unit_Number_Type;
-- With_Node is the Node_Id of a with statement for which the file could
-- not be found, and Spec_Name is the corresponding unit name. This call
-- creates a dummy package unit so that compilation can continue without

11
gcc/ada/lib-writ.adb
View File

@ -923,11 +923,13 @@ package body Lib.Writ is
end if;
end loop;
-- Output first restrictions line
-- Output restrictions line
Write_Info_Initiate ('R');
Write_Info_Char (' ');
-- First the information for the boolean restrictions
for R in All_Boolean_Restrictions loop
if Main_Restrictions.Set (R) then
Write_Info_Char ('r');
@ -938,13 +940,12 @@ package body Lib.Writ is
end if;
end loop;
Write_Info_EOL;
-- A separating space
-- Output second restrictions line
Write_Info_Initiate ('R');
Write_Info_Char (' ');
-- And now the information for the parameter restrictions
for RP in All_Parameter_Restrictions loop
if Main_Restrictions.Set (RP) then
Write_Info_Char ('r');

89
gcc/ada/lib-writ.ads
View File

@ -32,10 +32,6 @@ package Lib.Writ is
-- Format of Library Information --
-----------------------------------
-- Note: the contents of the ali file are summarized in the GNAT
-- user's guide, so if any non-trivial changes are made to this
-- section, they should be reflected in the user's guide.
-- This section describes the format of the library information that is
-- associated with object files. The exact method of this association is
-- potentially implementation dependent and is described and implemented
@ -50,6 +46,48 @@ package Lib.Writ is
-- Key_Character parameter parameter ...
-- The following sections describe the format of these lines in detail
--------------------------------------
-- Making Changes to the ALI Format --
--------------------------------------
-- A number of tools use ali.adb to parse ali files. This means
-- that changes to this format can cause old versions of these tools
-- to be incompatible with new versions of the compiler. Any changes
-- to ali file formats must be carefully evaluated to understand any
-- such possible conflicts, and in particular, it is very undesirable
-- to create conflicts between older versions of GPS and newer versions
-- of the compiler.
-- If the following guidelines are respected, downward compatibility
-- problems (old tools reading new ali files) should be minimized:
-- The basic key character format must be kept.
-- The V line must be the first line, this is checked by ali.adb
-- even in Ignore_Errors mode, and is used to verify that the file
-- at hand is indeed likely intended to be an ali file.
-- The P line must be present, though may be modified in contents
-- according to remaining guidelines. Again, ali.adb assumes the
-- P line is present even in Ignore_Errors mode.
-- New modifiers can generally be added (in particular adding new
-- two letter modifiers to the P or U lines is always safe)
-- Adding entirely new lines (with a new key letter) to the ali
-- file is always safe, at any point (other than before the V
-- line), since suchy lines will be ignored.
-- Following the guidelines in this section should ensure that this
-- problem is minimized and that old tools will be able to deal
-- successfully with new ali formats. Note that this does not apply
-- to the compiler itself, which always requires consistency between
-- the ali files and the binder. That is because one of the main
-- functions of the binder is to ensure consistency of the partition,
-- and this can be compromised if the ali files are inconsistent.
------------------
-- Header Lines --
------------------
@ -72,6 +110,10 @@ package Lib.Writ is
-- library info described in this package, or modifications to
-- calling sequences, or to the way that data is represented.
-- Note: the V line absolutely must be the first line, and no change
-- to the ALI format should change this, since even in Ignore_Errors
-- mode, Scan_ALI insists on finding a V line.
-- ---------------------
-- -- M Main Program --
-- ---------------------
@ -201,21 +243,26 @@ package Lib.Writ is
-- possible cases. These values are checked for consistency by the
-- binder and then copied to the generated binder output file.
-- Note: The P line must be present. Even in Ignore_Errors mode,
-- Scan_ALI insists on finding a P line. So if changes are made to
-- the ALI format, they should not include removing the P line!
-- ---------------------
-- -- R Restrictions --
-- ---------------------
-- Two lines are generated to record the status of restrictions that can
-- be specified by pragma Restrictions. The first of these lines refers
-- to Restriction_Id values:
-- The 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.
-- The format is:
-- R <<restriction-characters>>
-- R <<restriction-characters>> space <<restriction-param-id-entries>>
-- This line records information regarding restrictions that do
-- not take parameter values. Here "restriction-characters is a
-- string of characters, one for each value (in order) defined
-- in Restrict.All_Boolean_Restrictions. There are three possible
-- settings for each restriction:
-- The first parameter is a string of characters that records
-- information regarding restrictions that do not take parameter
-- not take parameter values. It is a string of characters, one
-- character for each value (in order) in All_Boolean_Restrictions.
-- There are three possible settings for each restriction:
-- r Restricted. Unit was compiled under control of a pragma
-- Restrictions for the corresponding restriction. In
@ -236,9 +283,8 @@ package Lib.Writ is
-- has "v", which is not permitted, since these restrictions
-- are partition-wide.
-- The second R line refers to parameter restrictions:
-- R <<restriction-parameter-id-entries>>
-- Following a space, the second parameter refers to restriction
-- identifiers for which a parameter is given.
-- The parameter is a string of entries, one for each value in
-- Restrict.All_Parameter_Restrictions. Each entry has two
@ -284,9 +330,14 @@ package Lib.Writ is
-- vN+ A violation was detected. The compiler cannot determine
-- the exact count of violations, but it is at least N.
-- There are no spaces in the line, so the entry for the example
-- in the header of this section for Max_Tasks would appear as
-- the string r4v3.
-- There are no spaces within the parameter string, so the entry
-- described above in the header of this section for Max_Tasks would
-- appear as the string r4v3.
-- Note: The restrictions line is required to be present. Even in
-- Ignore_Errors mode, Scan_ALI expects to find an R line and will
-- signal a fatal error if it is missing. This means that future
-- changes to the ALI file format must retain the R line.
-- ------------------------
-- -- I Interrupt States --

14
gcc/ada/namet.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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- --
@ -905,6 +905,18 @@ package body Namet is
and then C /= 'X';
end Is_OK_Internal_Letter;
----------------------
-- Is_Operator_Name --
----------------------
function Is_Operator_Name (Id : Name_Id) return Boolean is
S : Int;
begin
pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
S := Name_Entries.Table (Id).Name_Chars_Index;
return Name_Chars.Table (S + 1) = 'O';
end Is_Operator_Name;
--------------------
-- Length_Of_Name --
--------------------

6
gcc/ada/namet.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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- --
@ -204,6 +204,10 @@ package Namet is
pragma Inline (Get_Name_Table_Info);
-- Fetches the Int value associated with the given name
function Is_Operator_Name (Id : Name_Id) return Boolean;
-- Returns True if name given is of the form of an operator (that
-- is, it starts with an upper case O).
procedure Initialize;
-- Initializes the names table, including initializing the first 26
-- entries in the table (for the 1-character lower case names a-z)

12
gcc/ada/par-load.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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- --
@ -89,16 +89,18 @@ procedure Load is
function Same_File_Name_Except_For_Case
(Expected_File_Name : File_Name_Type;
Actual_File_Name : File_Name_Type)
return Boolean;
Actual_File_Name : File_Name_Type) return Boolean;
-- Given an actual file name and an expected file name (the latter being
-- derived from the unit name), determine if they are the same except for
-- possibly different casing of letters.
------------------------------------
-- Same_File_Name_Except_For_Case --
------------------------------------
function Same_File_Name_Except_For_Case
(Expected_File_Name : File_Name_Type;
Actual_File_Name : File_Name_Type)
return Boolean
Actual_File_Name : File_Name_Type) return Boolean
is
begin
Get_Name_String (Actual_File_Name);

3
gcc/ada/par-prag.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 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- --
@ -951,6 +951,7 @@ begin
Pragma_Persistent_Object |
Pragma_Preelaborate |
Pragma_Priority |
Pragma_Profile |
Pragma_Propagate_Exceptions |
Pragma_Psect_Object |
Pragma_Pure |

68
gcc/ada/sem_ch8.adb
View File

@ -756,7 +756,6 @@ package body Sem_Ch8 is
else
Error_Msg_N ("expect object name in renaming", Nam);
end if;
end if;
Set_Etype (Id, T2);
@ -1179,10 +1178,49 @@ package body Sem_Ch8 is
Old_S := Entity (Nam);
New_S := Analyze_Subprogram_Specification (Spec);
if Ekind (Entity (Nam)) = E_Operator
and then Box_Present (Inst_Node)
then
Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual);
-- Operator case
if Ekind (Entity (Nam)) = E_Operator then
-- Box present
if Box_Present (Inst_Node) then
Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual);
-- If there is an immediately visible homonym of the operator
-- and the declaration has a default, this is worth a warning
-- because the user probably did not intend to get the pre-
-- defined operator, visible in the generic declaration.
-- To find if there is an intended candidate, analyze the
-- renaming again in the current context.
elsif Scope (Old_S) = Standard_Standard
and then Present (Default_Name (Inst_Node))
then
declare
Decl : constant Node_Id := New_Copy_Tree (N);
Hidden : Entity_Id;
begin
Set_Entity (Name (Decl), Empty);
Analyze (Name (Decl));
Hidden :=
Find_Renamed_Entity (Decl, Name (Decl), New_S, True);
if Present (Hidden)
and then In_Open_Scopes (Scope (Hidden))
and then Is_Immediately_Visible (Hidden)
and then Comes_From_Source (Hidden)
and then Hidden /= Old_S
then
Error_Msg_Sloc := Sloc (Hidden);
Error_Msg_N ("?default subprogram is resolved " &
"in the generic declaration " &
"('R'M 12.6(17))", N);
Error_Msg_NE ("\?and will not use & #", N, Hidden);
end if;
end;
end if;
end if;
else
@ -2163,9 +2201,8 @@ package body Sem_Ch8 is
Elmt : Elmt_Id;
function Is_Primitive_Operator
(Op : Entity_Id;
F : Entity_Id)
return Boolean;
(Op : Entity_Id;
F : Entity_Id) return Boolean;
-- Check whether Op is a primitive operator of a use-visible type
---------------------------
@ -2173,9 +2210,8 @@ package body Sem_Ch8 is
---------------------------
function Is_Primitive_Operator
(Op : Entity_Id;
F : Entity_Id)
return Boolean
(Op : Entity_Id;
F : Entity_Id) return Boolean
is
T : constant Entity_Id := Etype (F);
@ -4730,10 +4766,8 @@ package body Sem_Ch8 is
-- Is_Appropriate_For_Record --
-------------------------------
function Is_Appropriate_For_Record
(T : Entity_Id)
return Boolean
is
function Is_Appropriate_For_Record (T : Entity_Id) return Boolean is
function Has_Components (T1 : Entity_Id) return Boolean;
-- Determine if given type has components (i.e. is either a record
-- type or a type that has discriminants).
@ -4968,6 +5002,10 @@ package body Sem_Ch8 is
-- Scan context clause of compilation unit to find a with_clause
-- for System.
-----------------
-- Find_System --
-----------------
function Find_System (C_Unit : Node_Id) return Entity_Id is
With_Clause : Node_Id;

33
gcc/ada/sem_prag.adb
View File

@ -7724,9 +7724,9 @@ package body Sem_Prag is
Set_Is_Preelaborated (Ent);
end;
------------------------
-- Persistent_Object --
------------------------
-----------------------
-- Persistent_Object --
-----------------------
when Pragma_Persistent_Object => declare
Decl : Node_Id;
@ -7738,6 +7738,7 @@ package body Sem_Prag is
GNAT_Pragma;
Check_Arg_Count (1);
Check_Arg_Is_Library_Level_Local_Name (Arg1);
if not Is_Entity_Name (Expression (Arg1))
or else
(Ekind (Entity (Expression (Arg1))) /= E_Variable
@ -7933,6 +7934,31 @@ package body Sem_Prag is
end if;
end Priority;
-------------
-- Profile --
-------------
-- pragma Profile (profile_IDENTIFIER);
-- profile_IDENTIFIER => Ravenscar
when Pragma_Profile =>
GNAT_Pragma;
Check_Arg_Count (1);
Check_Valid_Configuration_Pragma;
Check_No_Identifiers;
Set_Ravenscar (N);
declare
Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
begin
if Chars (Argx) = Name_Ravenscar then
Set_Ravenscar (N);
else
Error_Pragma_Arg ("& is not a valid profile", Argx);
end if;
end;
--------------------------
-- Propagate_Exceptions --
--------------------------
@ -9886,6 +9912,7 @@ package body Sem_Prag is
Pragma_Persistent_Object => -1,
Pragma_Preelaborate => -1,
Pragma_Priority => -1,
Pragma_Profile => 0,
Pragma_Propagate_Exceptions => -1,
Pragma_Psect_Object => -1,
Pragma_Pure => 0,

1
gcc/ada/snames.adb
View File

@ -173,6 +173,7 @@ package body Snames is
"polling#" &
"persistent_data#" &
"persistent_object#" &
"profile#" &
"propagate_exceptions#" &
"queuing_policy#" &
"ravenscar#" &

999
gcc/ada/snames.ads
View File

File diff suppressed because it is too large Load Diff

235
gcc/ada/snames.h
View File

@ -6,7 +6,7 @@
* *
* C Header File *
* *
* Copyright (C) 1992-2003 Free Software Foundation, Inc. *
* Copyright (C) 1992-2004 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- *
@ -220,128 +220,129 @@ extern unsigned char Get_Pragma_Id (int);
#define Pragma_Polling 21
#define Pragma_Persistent_Data 22
#define Pragma_Persistent_Object 23
#define Pragma_Propagate_Exceptions 24
#define Pragma_Queuing_Policy 25
#define Pragma_Ravenscar 26
#define Pragma_Restricted_Run_Time 27
#define Pragma_Restrictions 28
#define Pragma_Restriction_Warnings 29
#define Pragma_Reviewable 30
#define Pragma_Source_File_Name 31
#define Pragma_Source_File_Name_Project 32
#define Pragma_Style_Checks 33
#define Pragma_Suppress 34
#define Pragma_Suppress_Exception_Locations 35
#define Pragma_Task_Dispatching_Policy 36
#define Pragma_Universal_Data 37
#define Pragma_Unsuppress 38
#define Pragma_Use_VADS_Size 39
#define Pragma_Validity_Checks 40
#define Pragma_Warnings 41
#define Pragma_Profile 24
#define Pragma_Propagate_Exceptions 25
#define Pragma_Queuing_Policy 26
#define Pragma_Ravenscar 27
#define Pragma_Restricted_Run_Time 28
#define Pragma_Restrictions 29
#define Pragma_Restriction_Warnings 30
#define Pragma_Reviewable 31
#define Pragma_Source_File_Name 32
#define Pragma_Source_File_Name_Project 33
#define Pragma_Style_Checks 34
#define Pragma_Suppress 35
#define Pragma_Suppress_Exception_Locations 36
#define Pragma_Task_Dispatching_Policy 37
#define Pragma_Universal_Data 38
#define Pragma_Unsuppress 39
#define Pragma_Use_VADS_Size 40
#define Pragma_Validity_Checks 41
#define Pragma_Warnings 42
/* Remaining pragmas */
#define Pragma_Abort_Defer 42
#define Pragma_All_Calls_Remote 43
#define Pragma_Annotate 44
#define Pragma_Assert 45
#define Pragma_Asynchronous 46
#define Pragma_Atomic 47
#define Pragma_Atomic_Components 48
#define Pragma_Attach_Handler 49
#define Pragma_Comment 50
#define Pragma_Common_Object 51
#define Pragma_Complex_Representation 52
#define Pragma_Controlled 53
#define Pragma_Convention 54
#define Pragma_CPP_Class 55
#define Pragma_CPP_Constructor 56
#define Pragma_CPP_Virtual 57
#define Pragma_CPP_Vtable 58
#define Pragma_Debug 59
#define Pragma_Elaborate 60
#define Pragma_Elaborate_All 61
#define Pragma_Elaborate_Body 62
#define Pragma_Export 63
#define Pragma_Export_Exception 64
#define Pragma_Export_Function 65
#define Pragma_Export_Object 66
#define Pragma_Export_Procedure 67
#define Pragma_Export_Value 68
#define Pragma_Export_Valued_Procedure 69
#define Pragma_External 70
#define Pragma_Finalize_Storage_Only 71
#define Pragma_Ident 72
#define Pragma_Import 73
#define Pragma_Import_Exception 74
#define Pragma_Import_Function 75
#define Pragma_Import_Object 76
#define Pragma_Import_Procedure 77
#define Pragma_Import_Valued_Procedure 78
#define Pragma_Inline 79
#define Pragma_Inline_Always 80
#define Pragma_Inline_Generic 81
#define Pragma_Inspection_Point 82
#define Pragma_Interface 83
#define Pragma_Interface_Name 84
#define Pragma_Interrupt_Handler 85
#define Pragma_Interrupt_Priority 86
#define Pragma_Java_Constructor 87
#define Pragma_Java_Interface 88
#define Pragma_Keep_Names 89
#define Pragma_Link_With 90
#define Pragma_Linker_Alias 91
#define Pragma_Linker_Options 92
#define Pragma_Linker_Section 93
#define Pragma_List 94
#define Pragma_Machine_Attribute 95
#define Pragma_Main 96
#define Pragma_Main_Storage 97
#define Pragma_Memory_Size 98
#define Pragma_No_Return 99
#define Pragma_Obsolescent 100
#define Pragma_Optimize 101
#define Pragma_Optional_Overriding 102
#define Pragma_Overriding 103
#define Pragma_Pack 104
#define Pragma_Page 105
#define Pragma_Passive 106
#define Pragma_Preelaborate 107
#define Pragma_Priority 108
#define Pragma_Psect_Object 109
#define Pragma_Pure 110
#define Pragma_Pure_Function 111
#define Pragma_Remote_Call_Interface 112
#define Pragma_Remote_Types 113
#define Pragma_Share_Generic 114
#define Pragma_Shared 115
#define Pragma_Shared_Passive 116
#define Pragma_Source_Reference 117
#define Pragma_Stream_Convert 118
#define Pragma_Subtitle 119
#define Pragma_Suppress_All 120
#define Pragma_Suppress_Debug_Info 121
#define Pragma_Suppress_Initialization 122
#define Pragma_System_Name 123
#define Pragma_Task_Info 124
#define Pragma_Task_Name 125
#define Pragma_Task_Storage 126
#define Pragma_Thread_Body 127
#define Pragma_Time_Slice 128
#define Pragma_Title 129
#define Pragma_Unchecked_Union 130
#define Pragma_Unimplemented_Unit 131
#define Pragma_Unreferenced 132
#define Pragma_Unreserve_All_Interrupts 133
#define Pragma_Volatile 134
#define Pragma_Volatile_Components 135
#define Pragma_Weak_External 136
#define Pragma_Abort_Defer 43
#define Pragma_All_Calls_Remote 44
#define Pragma_Annotate 45
#define Pragma_Assert 46
#define Pragma_Asynchronous 47
#define Pragma_Atomic 48
#define Pragma_Atomic_Components 49
#define Pragma_Attach_Handler 50
#define Pragma_Comment 51
#define Pragma_Common_Object 52
#define Pragma_Complex_Representation 53
#define Pragma_Controlled 54
#define Pragma_Convention 55
#define Pragma_CPP_Class 56
#define Pragma_CPP_Constructor 57
#define Pragma_CPP_Virtual 58
#define Pragma_CPP_Vtable 59
#define Pragma_Debug 60
#define Pragma_Elaborate 61
#define Pragma_Elaborate_All 62
#define Pragma_Elaborate_Body 63
#define Pragma_Export 64
#define Pragma_Export_Exception 65
#define Pragma_Export_Function 66
#define Pragma_Export_Object 67
#define Pragma_Export_Procedure 68
#define Pragma_Export_Value 69
#define Pragma_Export_Valued_Procedure 70
#define Pragma_External 71
#define Pragma_Finalize_Storage_Only 72
#define Pragma_Ident 73
#define Pragma_Import 74
#define Pragma_Import_Exception 75
#define Pragma_Import_Function 76
#define Pragma_Import_Object 77
#define Pragma_Import_Procedure 78
#define Pragma_Import_Valued_Procedure 79
#define Pragma_Inline 80
#define Pragma_Inline_Always 81
#define Pragma_Inline_Generic 82
#define Pragma_Inspection_Point 83
#define Pragma_Interface 84
#define Pragma_Interface_Name 85
#define Pragma_Interrupt_Handler 86
#define Pragma_Interrupt_Priority 87
#define Pragma_Java_Constructor 88
#define Pragma_Java_Interface 89
#define Pragma_Keep_Names 90
#define Pragma_Link_With 91
#define Pragma_Linker_Alias 92
#define Pragma_Linker_Options 93
#define Pragma_Linker_Section 94
#define Pragma_List 95
#define Pragma_Machine_Attribute 96
#define Pragma_Main 97
#define Pragma_Main_Storage 98
#define Pragma_Memory_Size 99
#define Pragma_No_Return 100
#define Pragma_Obsolescent 101
#define Pragma_Optimize 102
#define Pragma_Optional_Overriding 103
#define Pragma_Overriding 104
#define Pragma_Pack 105
#define Pragma_Page 106
#define Pragma_Passive 107
#define Pragma_Preelaborate 108
#define Pragma_Priority 109
#define Pragma_Psect_Object 110
#define Pragma_Pure 111
#define Pragma_Pure_Function 112
#define Pragma_Remote_Call_Interface 113
#define Pragma_Remote_Types 114
#define Pragma_Share_Generic 115
#define Pragma_Shared 116
#define Pragma_Shared_Passive 117
#define Pragma_Source_Reference 118
#define Pragma_Stream_Convert 119
#define Pragma_Subtitle 120
#define Pragma_Suppress_All 121
#define Pragma_Suppress_Debug_Info 122
#define Pragma_Suppress_Initialization 123
#define Pragma_System_Name 124
#define Pragma_Task_Info 125
#define Pragma_Task_Name 126
#define Pragma_Task_Storage 127
#define Pragma_Thread_Body 128
#define Pragma_Time_Slice 129
#define Pragma_Title 130
#define Pragma_Unchecked_Union 131
#define Pragma_Unimplemented_Unit 132
#define Pragma_Unreferenced 133
#define Pragma_Unreserve_All_Interrupts 134
#define Pragma_Volatile 135
#define Pragma_Volatile_Components 136
#define Pragma_Weak_External 137
/* The following are deliberately out of alphabetical order, see Snames */
#define Pragma_AST_Entry 137
#define Pragma_Storage_Size 138
#define Pragma_Storage_Unit 139
#define Pragma_AST_Entry 138
#define Pragma_Storage_Size 139
#define Pragma_Storage_Unit 140
/* Define the numeric values for the conventions. */

6
gcc/ada/stylesw.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, 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- --
@ -134,7 +134,6 @@ package body Stylesw is
procedure Set_Style_Check_Options (Options : String) is
OK : Boolean;
EC : Natural;
begin
Set_Style_Check_Options (Options, OK, EC);
end Set_Style_Check_Options;
@ -194,6 +193,9 @@ package body Stylesw is
when 'n' =>
Style_Check_Standard := True;
when 'N' =>
Reset_Style_Check_Options;
when 'M' =>
Style_Max_Line_Length := 0;

5
gcc/ada/usage.adb
View File

@ -441,6 +441,11 @@ begin
Write_Line (" s check separate subprogram specs present");
Write_Line (" t check token separation rules");
-- Lines for -gnatyN switch
Write_Switch_Char ("yN");
Write_Line ("Cancel all previously set style checks");
-- Lines for -gnatz switch
Write_Switch_Char ("z");

6
gcc/ada/vms_data.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1996-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1996-2004 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- --
@ -1761,6 +1761,8 @@ package VMS_Data is
"-gnatyl " &
"LINE_LENGTH " &
"-gnatym " &
"NONE " &
"-gnatyN " &
"STANDARD_CASING " &
"-gnatyn " &
"ORDERED_SUBPROGRAMS " &
@ -1975,6 +1977,8 @@ package VMS_Data is
-- for possible special treatment of 80 character
-- lines.
--
-- NONE Clear any previously set style checks.
--
-- ORDERED_SUBPROGRAMS Check order of subprogram bodies.
-- All subprogram bodies in a given scope (e.g.
-- a package body) must be in alphabetical order.