mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-02-23 05:49:11 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2004-04-01  Robert Dewar  <dewar@gnat.com>

	* checks.adb: Minor reformatting throughout
	Note that prev checkin added RM reference to alignment warning

2004-04-01  Ed Schonberg  <schonberg@gnat.com>

	* exp_aggr.adb (Get_Component_Val): Treat a string literal as
	non-static when building aggregate for bit-packed array.

	* exp_ch4.adb (Expand_N_Slice): If a packed slice is an actual of a
	function call that is itself the actual in a procedure call, build
	temporary for it.

	* exp_pakd.adb (Expand_Bit_Packed_Element_Set): If right-hand side is
	a string literal, create a temporary for it, constant folding only
	handles scalars here.

2004-04-01  Vincent Celier  <celier@gnat.com>

	* ali-util.adb (Post_Scan, Error_Msg, Error_Msg_S, Error_Msg_SC,
	Error_Msg_SP): New empty procedures to instantiate the Scanner.
	(Style, Scanner): Instantiations of Styleg and Scng to be able to scan
	tokens.
	(Accumulate_Checksum, Initialize_Checksum): Remove procedures.
	(Get_File_Checksum): Use the instantiated scanner to scan all the tokens
	and get the checksum.

	* make.adb (Gnatmake): Do not insert into Q the Main_Source if it is
	already in the Q.
	Increase the Marking_Label at the end of the Multiple_Main_Loop,
	instead of at the beginning.

	* osint.adb (Lib_File_Name): Use Multi_Unit_Index_Character, not '~'
	directly.
	(Osint package elaboration): Change Multi_Unit_Index_Character to '$' if
	on VMS.

	* osint.ads (Multi_Unit_Index_Character): New Character global variable

	* osint-c.adb (Set_Library_Info_Name): Use Multi_Unit_Index_Character,
	not '~' directly.

	* par.adb: Remove test on file name to detect language defined units.
	Add test on unit name, after parsing, to detect language defined units
	that are not compiled with -gnatg (except System.RPC and its children)

	* par-ch10.adb (P_Compilation_Unit): In multi-unit sources, scan the
	following units without style checking.

	* switch-c.adb: Change -gnatC to -gnateI

	* usage.adb: Document new switch -gnateInnn

	* scng.adb (Accumulate_Token_Checksum): New procedure
	(Scan): Call Accumulate_Token_Checksum after each identifier, reserved
	word or literal number.
	(Scan.Nlit.Scan_Integer): Do not accumulate internal '_' in litteral
	numbers.

2004-04-01  Thomas Quinot  <quinot@act-europe.fr>

	* a-tasatt.adb,
	g-comlin.adb, sinput-c.adb, s-secsta.adb, s-tpobop.adb,
	switch-m.adb, 56taprop.adb, 5ginterr.adb, 5gmastop.adb,
	5staprop.adb, 5vinterr.adb, 5vtaprop.adb, 5vtpopde.adb,
	5vtpopde.adb: Add missing 'constant' keywords.

2004-04-01  Javier Miranda  <miranda@gnat.com>

	* par-ch4.adb: (P_Allocator): Code cleanup

	* sem_ch3.adb (Access_Definition): Properly set the null-excluding
	attribute.

	* sinfo.ads: Complete documentation of previous change

2004-04-01  GNAT Script  <nobody@gnat.com>

	* Make-lang.in: Makefile automatically updated

2004-04-01  Pascal Obry  <obry@gnat.com>

	* gnatlink.adb (Process_Binder_File): Remove duplicate linker options
	only on VMS.  This special handling was done because an old GNU/ld bug
	on Windows which has been fixed.

From-SVN: r80290
This commit is contained in:
Arnaud Charlet 2004-04-01 12:04:40 +02:00
parent 2ae6e9823a
commit 6b6fcd3ead
33 changed files with 516 additions and 401 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
gcc/ada/56taprop.adb
View File

@ -192,7 +192,7 @@ package body System.Task_Primitives.Operations is
procedure Abort_Handler (Sig : Signal) is
pragma Unreferenced (Sig);
T : Task_ID := Self;
T : constant Task_ID := Self;
Result : Interfaces.C.int;
Old_Set : aliased sigset_t;

4
gcc/ada/5ginterr.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2003 Free Software Fundation --
-- Copyright (C) 1998-2004 Free Software Fundation --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -631,7 +631,7 @@ package body System.Interrupts is
task body Server_Task is
Desc : Handler_Desc renames Descriptors (Interrupt);
Self_Id : Task_ID := STPO.Self;
Self_Id : constant Task_ID := STPO.Self;
Temp : Parameterless_Handler;
begin

2
gcc/ada/5gmastop.adb
View File

@ -288,7 +288,7 @@ package body System.Machine_State_Operations is
is
pragma Warnings (Off, Info);
Scp : Sigcontext_Ptr := To_Sigcontext_Ptr (M);
Scp : constant Sigcontext_Ptr := To_Sigcontext_Ptr (M);
procedure Exc_Unwind (Scp : Sigcontext_Ptr; Fde : Long_Integer := 0);
pragma Import (C, Exc_Unwind, "exc_unwind");

2
gcc/ada/5staprop.adb
View File

@ -1465,7 +1465,7 @@ package body System.Task_Primitives.Operations is
function Check_Sleep (Reason : Task_States) return Boolean is
pragma Unreferenced (Reason);
Self_ID : Task_ID := Self;
Self_ID : constant Task_ID := Self;
P : Lock_Ptr;
begin

2
gcc/ada/5vinterr.adb
View File

@ -951,7 +951,7 @@ package body System.Interrupts is
-----------------
task body Server_Task is
Self_ID : Task_ID := Self;
Self_ID : constant Task_ID := Self;
Tmp_Handler : Parameterless_Handler;
Tmp_ID : Task_ID;
Tmp_Entry_Index : Task_Entry_Index;

2
gcc/ada/5vtaprop.adb
View File

@ -161,7 +161,7 @@ package body System.Task_Primitives.Operations is
procedure Timer_Sleep_AST (ID : Address) is
Result : Interfaces.C.int;
Self_ID : Task_ID := To_Task_ID (ID);
Self_ID : constant Task_ID := To_Task_ID (ID);
begin
Self_ID.Common.LL.AST_Pending := False;
Result := pthread_cond_signal_int_np (Self_ID.Common.LL.CV'Access);

8
gcc/ada/5vtpopde.adb
View File

@ -84,7 +84,7 @@ package body System.Task_Primitives.Operations.DEC is
procedure Interrupt_AST_Handler (ID : Address) is
Result : Interfaces.C.int;
AST_Self_ID : Task_ID := To_Task_ID (ID);
AST_Self_ID : constant Task_ID := To_Task_ID (ID);
begin
Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access);
pragma Assert (Result = 0);
@ -95,7 +95,7 @@ package body System.Task_Primitives.Operations.DEC is
---------------------
procedure RMS_AST_Handler (ID : Address) is
AST_Self_ID : Task_ID := To_Task_Id (To_FAB_RAB (ID).CTX);
AST_Self_ID : constant Task_ID := To_Task_Id (To_FAB_RAB (ID).CTX);
Result : Interfaces.C.int;
begin
@ -109,7 +109,7 @@ package body System.Task_Primitives.Operations.DEC is
----------
function Self return Unsigned_Longword is
Self_ID : Task_ID := Self;
Self_ID : constant Task_ID := Self;
begin
Self_ID.Common.LL.AST_Pending := True;
return To_Unsigned_Longword (Self);
@ -121,7 +121,7 @@ package body System.Task_Primitives.Operations.DEC is
procedure Starlet_AST_Handler (ID : Address) is
Result : Interfaces.C.int;
AST_Self_ID : Task_ID := To_Task_ID (ID);
AST_Self_ID : constant Task_ID := To_Task_ID (ID);
begin
AST_Self_ID.Common.LL.AST_Pending := False;
Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access);

87
gcc/ada/ChangeLog
View File

@ -1,3 +1,90 @@
2004-04-01 Robert Dewar <dewar@gnat.com>
* checks.adb: Minor reformatting throughout
Note that prev checkin added RM reference to alignment warning
2004-04-01 Ed Schonberg <schonberg@gnat.com>
* exp_aggr.adb (Get_Component_Val): Treat a string literal as
non-static when building aggregate for bit-packed array.
* exp_ch4.adb (Expand_N_Slice): If a packed slice is an actual of a
function call that is itself the actual in a procedure call, build
temporary for it.
* exp_pakd.adb (Expand_Bit_Packed_Element_Set): If right-hand side is
a string literal, create a temporary for it, constant folding only
handles scalars here.
2004-04-01 Vincent Celier <celier@gnat.com>
* ali-util.adb (Post_Scan, Error_Msg, Error_Msg_S, Error_Msg_SC,
Error_Msg_SP): New empty procedures to instantiate the Scanner.
(Style, Scanner): Instantiations of Styleg and Scng to be able to scan
tokens.
(Accumulate_Checksum, Initialize_Checksum): Remove procedures.
(Get_File_Checksum): Use the instantiated scanner to scan all the tokens
and get the checksum.
* make.adb (Gnatmake): Do not insert into Q the Main_Source if it is
already in the Q.
Increase the Marking_Label at the end of the Multiple_Main_Loop,
instead of at the beginning.
* osint.adb (Lib_File_Name): Use Multi_Unit_Index_Character, not '~'
directly.
(Osint package elaboration): Change Multi_Unit_Index_Character to '$' if
on VMS.
* osint.ads (Multi_Unit_Index_Character): New Character global variable
* osint-c.adb (Set_Library_Info_Name): Use Multi_Unit_Index_Character,
not '~' directly.
* par.adb: Remove test on file name to detect language defined units.
Add test on unit name, after parsing, to detect language defined units
that are not compiled with -gnatg (except System.RPC and its children)
* par-ch10.adb (P_Compilation_Unit): In multi-unit sources, scan the
following units without style checking.
* switch-c.adb: Change -gnatC to -gnateI
* usage.adb: Document new switch -gnateInnn
* scng.adb (Accumulate_Token_Checksum): New procedure
(Scan): Call Accumulate_Token_Checksum after each identifier, reserved
word or literal number.
(Scan.Nlit.Scan_Integer): Do not accumulate internal '_' in litteral
numbers.
2004-04-01 Thomas Quinot <quinot@act-europe.fr>
* a-tasatt.adb,
g-comlin.adb, sinput-c.adb, s-secsta.adb, s-tpobop.adb,
switch-m.adb, 56taprop.adb, 5ginterr.adb, 5gmastop.adb,
5staprop.adb, 5vinterr.adb, 5vtaprop.adb, 5vtpopde.adb,
5vtpopde.adb: Add missing 'constant' keywords.
2004-04-01 Javier Miranda <miranda@gnat.com>
* par-ch4.adb: (P_Allocator): Code cleanup
* sem_ch3.adb (Access_Definition): Properly set the null-excluding
attribute.
* sinfo.ads: Complete documentation of previous change
2004-04-01 Pascal Obry <obry@gnat.com>
* gnatlink.adb (Process_Binder_File): Remove duplicate linker options
only on VMS. This special handling was done because an old GNU/ld bug
on Windows which has been fixed.
2004-04-01 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
2004-03-31 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* decl.c (gnat_to_gnu_entity, make_type_from_size):

69
gcc/ada/Make-lang.in
View File

@ -189,6 +189,9 @@ GNATBIND_OBJS = \
ada/debug.o \
ada/einfo.o \
ada/elists.o \
ada/err_vars.o \
ada/errout.o \
ada/erroutc.o \
ada/fmap.o \
ada/fname.o \
ada/g-hesora.o \
@ -235,14 +238,20 @@ GNATBIND_OBJS = \
ada/s-wchcnv.o \
ada/s-wchcon.o \
ada/s-wchjis.o \
ada/scng.o \
ada/scans.o \
ada/sdefault.o \
ada/sinfo.o \
ada/sinput.o \
ada/sinput-c.o \
ada/snames.o \
ada/stand.o \
ada/stringt.o \
ada/switch-b.o \
ada/switch.o \
ada/style.o \
ada/styleg.o \
ada/stylesw.o \
ada/system.o \
ada/table.o \
ada/targparm.o \
@ -1269,16 +1278,21 @@ ada/ada.o : ada/ada.ads ada/system.ads
ada/ali-util.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads ada/ali.ads \
ada/ali-util.ads ada/ali-util.adb ada/alloc.ads ada/binderr.ads \
ada/casing.ads ada/debug.ads ada/gnat.ads ada/g-htable.ads \
ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
ada/interfac.ads ada/lib.ads ada/namet.ads ada/namet.adb ada/opt.ads \
ada/osint.ads ada/output.ads ada/rident.ads ada/system.ads \
ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads ada/s-exctab.adb \
ada/s-htable.ads ada/s-htable.adb ada/s-memory.ads ada/s-rident.ads \
ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \
ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \
ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads
ada/casing.ads ada/csets.ads ada/debug.ads ada/err_vars.ads \
ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads \
ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \
ada/namet.ads ada/namet.adb ada/opt.ads ada/osint.ads ada/output.ads \
ada/rident.ads ada/scans.ads ada/scng.ads ada/scng.adb ada/sinput.ads \
ada/sinput.adb ada/sinput-c.ads ada/snames.ads ada/stringt.ads \
ada/stringt.adb ada/styleg.ads ada/styleg.adb ada/stylesw.ads \
ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-crc32.adb \
ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb ada/s-memory.ads \
ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads \
ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
ada/tree_io.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \
ada/widechar.ads
ada/ali.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads ada/ali.ads \
ada/ali.adb ada/alloc.ads ada/butil.ads ada/casing.ads ada/debug.ads \
@ -1327,17 +1341,20 @@ ada/back_end.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/bcheck.o : ada/ada.ads ada/a-except.ads ada/ali.ads ada/ali-util.ads \
ada/ali-util.adb ada/alloc.ads ada/bcheck.ads ada/bcheck.adb \
ada/binderr.ads ada/butil.ads ada/casing.ads ada/debug.ads \
ada/fname.ads ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads \
ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads \
ada/lib.ads ada/namet.ads ada/namet.adb ada/opt.ads ada/osint.ads \
ada/output.ads ada/rident.ads ada/system.ads ada/s-crc32.ads \
ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads ada/s-imgenu.ads \
ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \
ada/unchdeal.ads ada/widechar.ads
ada/binderr.ads ada/butil.ads ada/casing.ads ada/csets.ads \
ada/debug.ads ada/err_vars.ads ada/fname.ads ada/gnat.ads \
ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/namet.ads \
ada/namet.adb ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \
ada/scans.ads ada/scng.ads ada/scng.adb ada/sinput.ads ada/sinput-c.ads \
ada/snames.ads ada/stringt.ads ada/styleg.ads ada/styleg.adb \
ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \
ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads \
ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \
ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \
ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
ada/urealp.ads ada/widechar.ads
ada/binde.o : ada/ada.ads ada/a-except.ads ada/ali.ads ada/alloc.ads \
ada/binde.ads ada/binde.adb ada/binderr.ads ada/butil.ads \
@ -3657,6 +3674,16 @@ ada/sinfo.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/sinput-c.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/alloc.ads ada/casing.ads ada/debug.ads ada/gnat.ads \
ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
ada/namet.ads ada/opt.ads ada/output.ads ada/sinput.ads \
ada/sinput-c.ads ada/sinput-c.adb ada/system.ads ada/s-exctab.ads \
ada/s-memory.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \
ada/unchdeal.ads
ada/sinput-d.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/casing.ads \
ada/debug.ads ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads \
ada/gnatvsn.ads ada/hostparm.ads ada/opt.ads ada/osint.ads \

18
gcc/ada/a-tasatt.adb
View File

@ -394,8 +394,8 @@ package body Ada.Task_Attributes is
(T : Task_Identification.Task_Id := Task_Identification.Current_Task)
return Attribute_Handle
is
TT : Task_ID := To_Task_ID (T);
Error_Message : constant String := "Trying to get the reference of a ";
TT : constant Task_ID := To_Task_ID (T);
Error_Message : constant String := "Trying to get the reference of a ";
begin
if TT = null then
@ -484,8 +484,8 @@ package body Ada.Task_Attributes is
procedure Reinitialize
(T : Task_Identification.Task_Id := Task_Identification.Current_Task)
is
TT : Task_ID := To_Task_ID (T);
Error_Message : constant String := "Trying to Reinitialize a ";
TT : constant Task_ID := To_Task_ID (T);
Error_Message : constant String := "Trying to Reinitialize a ";
begin
if TT = null then
@ -554,8 +554,8 @@ package body Ada.Task_Attributes is
(Val : Attribute;
T : Task_Identification.Task_Id := Task_Identification.Current_Task)
is
TT : Task_ID := To_Task_ID (T);
Error_Message : constant String := "Trying to Set the Value of a ";
TT : constant Task_ID := To_Task_ID (T);
Error_Message : constant String := "Trying to Set the Value of a ";
begin
if TT = null then
@ -640,11 +640,11 @@ package body Ada.Task_Attributes is
-----------
function Value
(T : Task_Identification.Task_Id := Task_Identification.Current_Task)
(T : Task_Identification.Task_Id := Task_Identification.Current_Task)
return Attribute
is
TT : Task_ID := To_Task_ID (T);
Error_Message : constant String := "Trying to get the Value of a ";
TT : constant Task_ID := To_Task_ID (T);
Error_Message : constant String := "Trying to get the Value of a ";
begin
if TT = null then

302
gcc/ada/ali-util.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- --
@ -31,12 +31,39 @@ with Namet; use Namet;
with Opt; use Opt;
with Output; use Output;
with Osint; use Osint;
with System.CRC32;
with System.Memory;
with Scans; use Scans;
with Scng;
with Sinput.C;
with Snames; use Snames;
with Styleg;
package body ALI.Util is
-- Empty procedures needed to instantiate Scng. Error procedures are
-- empty, because we don't want to report any errors when computing
-- a source checksum.
procedure Post_Scan;
procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr);
procedure Error_Msg_S (Msg : String);
procedure Error_Msg_SC (Msg : String);
procedure Error_Msg_SP (Msg : String);
-- Instantiation of Styleg, needed to instantiate Scng
package Style is new Styleg
(Error_Msg, Error_Msg_S, Error_Msg_SC, Error_Msg_SP);
-- A Scanner is needed to get checksum of a source (procedure
-- Get_File_Checksum).
package Scanner is new Scng
(Post_Scan, Error_Msg, Error_Msg_S, Error_Msg_SC, Error_Msg_SP, Style);
type Header_Num is range 0 .. 1_000;
function Hash (F : File_Name_Type) return Header_Num;
@ -50,33 +77,6 @@ package body ALI.Util is
Hash => Hash,
Equal => "=");
-----------------------
-- Local Subprograms --
-----------------------
procedure Accumulate_Checksum (C : Character; Csum : in out Word);
pragma Inline (Accumulate_Checksum);
-- This routine accumulates the checksum given character C. During the
-- scanning of a source file, this routine is called with every character
-- in the source, excluding blanks, and all control characters (except
-- that ESC is included in the checksum). Upper case letters not in string
-- literals are folded by the caller. See Sinput spec for the documentation
-- of the checksum algorithm. Note: checksum values are only used if we
-- generate code, so it is not necessary to worry about making the right
-- sequence of calls in any error situation.
procedure Initialize_Checksum (Csum : out Word);
-- Sets initial value of Csum before any calls to Accumulate_Checksum
-------------------------
-- Accumulate_Checksum --
-------------------------
procedure Accumulate_Checksum (C : Character; Csum : in out Word) is
begin
System.CRC32.Update (System.CRC32.CRC32 (Csum), C);
end Accumulate_Checksum;
---------------------
-- Checksums_Match --
---------------------
@ -86,182 +86,92 @@ package body ALI.Util is
return Checksum1 = Checksum2 and then Checksum1 /= Checksum_Error;
end Checksums_Match;
pragma Warnings (Off);
-- To avoid warnings on non referenced parameters of the error procedures
---------------
-- Error_Msg --
---------------
procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
begin
null;
end Error_Msg;
pragma Warnings (Off);
-- To avoid warnings on non referenced parameters of the error procedures
-----------------
-- Error_Msg_S --
-----------------
procedure Error_Msg_S (Msg : String) is
begin
null;
end Error_Msg_S;
------------------
-- Error_Msg_SC --
------------------
procedure Error_Msg_SC (Msg : String) is
begin
null;
end Error_Msg_SC;
------------------
-- Error_Msg_SP --
------------------
procedure Error_Msg_SP (Msg : String) is
begin
null;
end Error_Msg_SP;
pragma Warnings (On);
-----------------------
-- Get_File_Checksum --
-----------------------
function Get_File_Checksum (Fname : Name_Id) return Word is
Src : Source_Buffer_Ptr;
Hi : Source_Ptr;
Csum : Word;
Ptr : Source_Ptr;
Bad : exception;
-- Raised if file not found, or file format error
use ASCII;
-- Make control characters visible
Full_Name : Name_Id;
Source_Index : Source_File_Index;
begin
Read_Source_File (Fname, 0, Hi, Src);
Full_Name := Find_File (Fname, Osint.Source);
-- If we cannot find the file, then return an impossible checksum,
-- impossible becaues checksums have the high order bit zero, so
-- that checksums do not match.
if Src = null then
raise Bad;
if Full_Name = No_File then
return Checksum_Error;
end if;
Initialize_Checksum (Csum);
Ptr := 0;
Source_Index := Sinput.C.Load_File (Get_Name_String (Full_Name));
if Source_Index = No_Source_File then
return Checksum_Error;
end if;
Scanner.Initialize_Scanner (Types.No_Unit, Source_Index);
-- Make sure that the project language reserved words are not
-- recognized as reserved words, but as identifiers. The byte info for
-- those names have been set if we are in gnatmake.
Set_Name_Table_Byte (Name_Project, 0);
Set_Name_Table_Byte (Name_Extends, 0);
Set_Name_Table_Byte (Name_External, 0);
-- Scan the complete file to compute its checksum
loop
case Src (Ptr) is
-- Spaces and formatting information are ignored in checksum
when ' ' | CR | LF | VT | FF | HT =>
Ptr := Ptr + 1;
-- EOF is ignored unless it is the last character
when EOF =>
if Ptr = Hi then
System.Memory.Free (Src.all'Address);
return Csum;
else
Ptr := Ptr + 1;
end if;
-- Non-blank characters that are included in the checksum
when '#' | '&' | '*' | ':' | '(' | ',' | '.' | '=' | '>' |
'<' | ')' | '/' | ';' | '|' | '!' | '+' | '_' |
'0' .. '9' | 'a' .. 'z'
=>
Accumulate_Checksum (Src (Ptr), Csum);
Ptr := Ptr + 1;
-- Upper case letters, fold to lower case
when 'A' .. 'Z' =>
Accumulate_Checksum
(Character'Val (Character'Pos (Src (Ptr)) + 32), Csum);
Ptr := Ptr + 1;
-- Left bracket, really should do wide character thing here,
-- but for now, don't bother.
when '[' =>
raise Bad;
-- Minus, could be comment
when '-' =>
if Src (Ptr + 1) = '-' then
Ptr := Ptr + 2;
while Src (Ptr) >= ' ' or else Src (Ptr) = HT loop
Ptr := Ptr + 1;
end loop;
else
Accumulate_Checksum ('-', Csum);
Ptr := Ptr + 1;
end if;
-- String delimited by double quote
when '"' =>
Accumulate_Checksum ('"', Csum);
loop
Ptr := Ptr + 1;
exit when Src (Ptr) = '"';
if Src (Ptr) < ' ' then
raise Bad;
end if;
Accumulate_Checksum (Src (Ptr), Csum);
end loop;
Accumulate_Checksum ('"', Csum);
Ptr := Ptr + 1;
-- String delimited by percent
when '%' =>
Accumulate_Checksum ('%', Csum);
loop
Ptr := Ptr + 1;
exit when Src (Ptr) = '%';
if Src (Ptr) < ' ' then
raise Bad;
end if;
Accumulate_Checksum (Src (Ptr), Csum);
end loop;
Accumulate_Checksum ('%', Csum);
Ptr := Ptr + 1;
-- Quote, could be character constant
when ''' =>
Accumulate_Checksum (''', Csum);
if Src (Ptr + 2) = ''' then
Accumulate_Checksum (Src (Ptr + 1), Csum);
Accumulate_Checksum (''', Csum);
Ptr := Ptr + 3;
-- Otherwise assume attribute char. We should deal with wide
-- character cases here, but that's hard, so forget it.
else
Ptr := Ptr + 1;
end if;
-- Upper half character, more to be done here, we should worry
-- about folding Latin-1, folding other character sets, and
-- dealing with the nasty case of upper half wide encoding.
when Upper_Half_Character =>
Accumulate_Checksum (Src (Ptr), Csum);
Ptr := Ptr + 1;
-- Escape character, we should do the wide character thing here,
-- but for now, do not bother.
when ESC =>
raise Bad;
-- Invalid control characters
when NUL | SOH | STX | ETX | EOT | ENQ | ACK | BEL | BS | SO |
SI | DLE | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN |
EM | FS | GS | RS | US | DEL
=>
raise Bad;
-- Invalid graphic characters
when '$' | '?' | '@' | '`' | '\' |
'^' | '~' | ']' | '{' | '}'
=>
raise Bad;
end case;
Scanner.Scan;
exit when Token = Tok_EOF;
end loop;
exception
when Bad =>
System.Memory.Free (Src.all'Address);
return Checksum_Error;
return Scans.Checksum;
end Get_File_Checksum;
----------
@ -293,14 +203,14 @@ package body ALI.Util is
Interfaces.Reset;
end Initialize_ALI_Source;
-------------------------
-- Initialize_Checksum --
-------------------------
---------------
-- Post_Scan --
---------------
procedure Initialize_Checksum (Csum : out Word) is
procedure Post_Scan is
begin
System.CRC32.Initialize (System.CRC32.CRC32 (Csum));
end Initialize_Checksum;
null;
end Post_Scan;
--------------
-- Read_ALI --

78
gcc/ada/checks.adb
View File

@ -238,8 +238,7 @@ package body Checks is
function Guard_Access
(Cond : Node_Id;
Loc : Source_Ptr;
Ck_Node : Node_Id)
return Node_Id;
Ck_Node : Node_Id) return Node_Id;
-- In the access type case, guard the test with a test to ensure
-- that the access value is non-null, since the checks do not
-- not apply to null access values.
@ -256,8 +255,7 @@ package body Checks is
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Warn_Node : Node_Id)
return Check_Result;
Warn_Node : Node_Id) return Check_Result;
-- Like Apply_Selected_Length_Checks, except it doesn't modify
-- anything, just returns a list of nodes as described in the spec of
-- this package for the Range_Check function.
@ -266,8 +264,7 @@ package body Checks is
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Warn_Node : Node_Id)
return Check_Result;
Warn_Node : Node_Id) return Check_Result;
-- Like Apply_Selected_Range_Checks, except it doesn't modify anything,
-- just returns a list of nodes as described in the spec of this package
-- for the Range_Check function.
@ -2098,8 +2095,7 @@ package body Checks is
function Build_Discriminant_Checks
(N : Node_Id;
T_Typ : Entity_Id)
return Node_Id
T_Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Cond : Node_Id;
@ -3487,8 +3483,7 @@ package body Checks is
is
function Within_Range_Of
(Target_Type : Entity_Id;
Check_Type : Entity_Id)
return Boolean;
Check_Type : Entity_Id) return Boolean;
-- Given a requirement for checking a range against Target_Type, and
-- and a range Check_Type against which a check has already been made,
-- determines if the check against check type is sufficient to ensure
@ -3500,8 +3495,7 @@ package body Checks is
function Within_Range_Of
(Target_Type : Entity_Id;
Check_Type : Entity_Id)
return Boolean
Check_Type : Entity_Id) return Boolean
is
begin
if Target_Type = Check_Type then
@ -4191,8 +4185,7 @@ package body Checks is
function Guard_Access
(Cond : Node_Id;
Loc : Source_Ptr;
Ck_Node : Node_Id)
return Node_Id
Ck_Node : Node_Id) return Node_Id
is
begin
if Nkind (Cond) = N_Or_Else then
@ -4480,8 +4473,7 @@ package body Checks is
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id := Empty;
Warn_Node : Node_Id := Empty)
return Check_Result
Warn_Node : Node_Id := Empty) return Check_Result
is
begin
return Selected_Range_Checks
@ -4607,8 +4599,7 @@ package body Checks is
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Warn_Node : Node_Id)
return Check_Result
Warn_Node : Node_Id) return Check_Result
is
Loc : constant Source_Ptr := Sloc (Ck_Node);
S_Typ : Entity_Id;
@ -4626,6 +4617,7 @@ package body Checks is
function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id;
function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id;
-- Comments required ???
function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean;
-- True for equal literals and for nodes that denote the same constant
@ -4636,16 +4628,14 @@ package body Checks is
function Length_E_Cond
(Exptyp : Entity_Id;
Typ : Entity_Id;
Indx : Nat)
return Node_Id;
Indx : Nat) return Node_Id;
-- Returns expression to compute:
-- Typ'Length /= Exptyp'Length
function Length_N_Cond
(Expr : Node_Id;
Typ : Entity_Id;
Indx : Nat)
return Node_Id;
Indx : Nat) return Node_Id;
-- Returns expression to compute:
-- Typ'Length /= Expr'Length
@ -4812,8 +4802,7 @@ package body Checks is
function Length_E_Cond
(Exptyp : Entity_Id;
Typ : Entity_Id;
Indx : Nat)
return Node_Id
Indx : Nat) return Node_Id
is
begin
return
@ -4830,8 +4819,7 @@ package body Checks is
function Length_N_Cond
(Expr : Node_Id;
Typ : Entity_Id;
Indx : Nat)
return Node_Id
Indx : Nat) return Node_Id
is
begin
return
@ -5113,8 +5101,7 @@ package body Checks is
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Warn_Node : Node_Id)
return Check_Result
Warn_Node : Node_Id) return Check_Result
is
Loc : constant Source_Ptr := Sloc (Ck_Node);
S_Typ : Entity_Id;
@ -5132,8 +5119,7 @@ package body Checks is
function Discrete_Range_Cond
(Expr : Node_Id;
Typ : Entity_Id)
return Node_Id;
Typ : Entity_Id) return Node_Id;
-- Returns expression to compute:
-- Low_Bound (Expr) < Typ'First
-- or else
@ -5141,8 +5127,7 @@ package body Checks is
function Discrete_Expr_Cond
(Expr : Node_Id;
Typ : Entity_Id)
return Node_Id;
Typ : Entity_Id) return Node_Id;
-- Returns expression to compute:
-- Expr < Typ'First
-- or else
@ -5151,8 +5136,7 @@ package body Checks is
function Get_E_First_Or_Last
(E : Entity_Id;
Indx : Nat;
Nam : Name_Id)
return Node_Id;
Nam : Name_Id) return Node_Id;
-- Returns expression to compute:
-- E'First or E'Last
@ -5172,16 +5156,14 @@ package body Checks is
function Range_Equal_E_Cond
(Exptyp : Entity_Id;
Typ : Entity_Id;
Indx : Nat)
return Node_Id;
Indx : Nat) return Node_Id;
-- Returns expression to compute:
-- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
function Range_N_Cond
(Expr : Node_Id;
Typ : Entity_Id;
Indx : Nat)
return Node_Id;
Indx : Nat) return Node_Id;
-- Return expression to compute:
-- Expr'First < Typ'First or else Expr'Last > Typ'Last
@ -5211,8 +5193,7 @@ package body Checks is
function Discrete_Expr_Cond
(Expr : Node_Id;
Typ : Entity_Id)
return Node_Id
Typ : Entity_Id) return Node_Id
is
begin
return
@ -5243,8 +5224,7 @@ package body Checks is
function Discrete_Range_Cond
(Expr : Node_Id;
Typ : Entity_Id)
return Node_Id
Typ : Entity_Id) return Node_Id
is
LB : Node_Id := Low_Bound (Expr);
HB : Node_Id := High_Bound (Expr);
@ -5318,8 +5298,7 @@ package body Checks is
function Get_E_First_Or_Last
(E : Entity_Id;
Indx : Nat;
Nam : Name_Id)
return Node_Id
Nam : Name_Id) return Node_Id
is
N : Node_Id;
LB : Node_Id;
@ -5432,7 +5411,6 @@ package body Checks is
Duplicate_Subexpr_No_Checks (N, Name_Req => True),
Expressions => New_List (
Make_Integer_Literal (Loc, Indx)));
end Get_N_First;
----------------
@ -5448,7 +5426,6 @@ package body Checks is
Duplicate_Subexpr_No_Checks (N, Name_Req => True),
Expressions => New_List (
Make_Integer_Literal (Loc, Indx)));
end Get_N_Last;
------------------
@ -5458,8 +5435,7 @@ package body Checks is
function Range_E_Cond
(Exptyp : Entity_Id;
Typ : Entity_Id;
Indx : Nat)
return Node_Id
Indx : Nat) return Node_Id
is
begin
return
@ -5483,8 +5459,7 @@ package body Checks is
function Range_Equal_E_Cond
(Exptyp : Entity_Id;
Typ : Entity_Id;
Indx : Nat)
return Node_Id
Indx : Nat) return Node_Id
is
begin
return
@ -5506,8 +5481,7 @@ package body Checks is
function Range_N_Cond
(Expr : Node_Id;
Typ : Entity_Id;
Indx : Nat)
return Node_Id
Indx : Nat) return Node_Id
is
begin
return

8
gcc/ada/exp_aggr.adb
View File

@ -4872,9 +4872,13 @@ package body Exp_Aggr is
Analyze_And_Resolve (N, Ctyp);
-- Must have a compile time value
-- Must have a compile time value. String literals have to
-- be converted into temporaries as well, because they cannot
-- easily be converted into their bit representation.
if not Compile_Time_Known_Value (N) then
if not Compile_Time_Known_Value (N)
or else Nkind (N) = N_String_Literal
then
raise Not_Handled;
end if;

4
gcc/ada/exp_ch4.adb
View File

@ -5352,6 +5352,10 @@ package body Exp_Ch4 is
loop
if Nkind (Par) = N_Procedure_Call_Statement then
return True;
elsif Nkind (Par) = N_Function_Call then
return False;
else
Par := Parent (Par);
end if;

20
gcc/ada/exp_pakd.adb
View File

@ -1282,6 +1282,26 @@ package body Exp_Pakd is
-- conversion is analyzed immediately so that subsequent processing
-- can work with an analyzed Rhs (and e.g. look at its Etype)
-- If the right-hand side is a string literal, create a temporary for
-- it, constant-folding is not ready to wrap the bit representation
-- of a string literal.
if Nkind (Rhs) = N_String_Literal then
declare
Decl : Node_Id;
begin
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, New_Internal_Name ('T')),
Object_Definition => New_Occurrence_Of (Ctyp, Loc),
Expression => New_Copy_Tree (Rhs));
Insert_Actions (N, New_List (Decl));
Rhs := New_Occurrence_Of (Defining_Identifier (Decl), Loc);
end;
end if;
Rhs := Convert_To (Ctyp, Rhs);
Set_Parent (Rhs, N);
Analyze_And_Resolve (Rhs, Ctyp);

4
gcc/ada/g-comlin.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1999-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- --
@ -144,7 +144,7 @@ package body GNAT.Command_Line is
S : String (1 .. 1024);
Last : Natural;
It : Pointer := Iterator'Unrestricted_Access;
It : constant Pointer := Iterator'Unrestricted_Access;
Current : Depth := It.Current_Depth;
NL : Positive;

5
gcc/ada/gnatlink.adb
View File

@ -988,7 +988,10 @@ procedure Gnatlink is
-- Add binder options only if not already set on the command
-- line. This rule is a way to control the linker options order.
elsif not Is_Option_Present (Next_Line (Nfirst .. Nlast)) then
elsif not (Hostparm.OpenVMS
and then
Is_Option_Present (Next_Line (Nfirst .. Nlast)))
then
if Nlast > Nfirst + 2 and then
Next_Line (Nfirst .. Nfirst + 1) = "-L"
then

41
gcc/ada/make.adb
View File

@ -828,9 +828,8 @@ package body Make is
else
while Last_Argument + Args'Length > Arguments'Last loop
declare
New_Arguments : Argument_List_Access :=
new Argument_List (1 .. Arguments'Last * 2);
New_Arguments : constant Argument_List_Access :=
new Argument_List (1 .. Arguments'Last * 2);
begin
New_Arguments (1 .. Last_Argument) :=
Arguments (1 .. Last_Argument);
@ -2553,8 +2552,13 @@ package body Make is
Check_Source_Files := True;
All_Sources := False;
Insert_Q (Main_Source);
Mark (Main_Source);
-- Only insert in the Q if it is not already done, to avoid simultaneous
-- compilations if -jnnn is used.
if not Is_Marked (Main_Source) then
Insert_Q (Main_Source);
Mark (Main_Source);
end if;
First_Compiled_File := No_File;
Most_Recent_Obj_File := No_File;
@ -4305,18 +4309,6 @@ package body Make is
Multiple_Main_Loop : for N_File in 1 .. Osint.Number_Of_Files loop
-- Increase the marking label to be sure to check sources
-- for all executables.
Marking_Label := Marking_Label + 1;
-- Make sure it is not 0, which is the default value for
-- a file that has never been marked.
if Marking_Label = 0 then
Marking_Label := 1;
end if;
-- First, find the executable name and path
Executable := No_File;
@ -5443,6 +5435,18 @@ package body Make is
end;
end if;
end if;
-- Increase the marking label to be sure to check sources
-- for all executables.
Marking_Label := Marking_Label + 1;
-- Make sure it is not 0, which is the default value for
-- a file that has never been marked.
if Marking_Label = 0 then
Marking_Label := 1;
end if;
end loop Multiple_Main_Loop;
if Failed_Links.Last > 0 then
@ -7214,7 +7218,8 @@ package body Make is
end Verbose_Msg;
begin
-- Make sure that in case of failure, the temp files will be deleted
Prj.Com.Fail := Make_Failed'Access;
MLib.Fail := Make_Failed'Access;
-- Make sure that in case of failure, the temp files will be deleted
end Make;

2
gcc/ada/osint-c.adb
View File

@ -272,7 +272,7 @@ package body Osint.C is
Exten : constant String := Name_Buffer (Dot_Index .. Name_Len);
begin
Name_Len := Dot_Index - 1;
Add_Char_To_Name_Buffer ('~');
Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
Add_Nat_To_Name_Buffer (Multiple_Unit_Index);
Dot_Index := Name_Len + 1;
Add_Str_To_Name_Buffer (Exten);

11
gcc/ada/osint.adb
View File

@ -1406,7 +1406,7 @@ package body Osint is
end loop;
if Munit_Index /= 0 then
Add_Char_To_Name_Buffer ('~');
Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
Add_Nat_To_Name_Buffer (Munit_Index);
end if;
@ -2132,7 +2132,7 @@ package body Osint is
type Actual_Source_Ptr is access Actual_Source_Buffer;
-- This is the pointer type for the physical buffer allocated
Actual_Ptr : Actual_Source_Ptr := new Actual_Source_Buffer;
Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer;
-- And this is the actual physical buffer
begin
@ -2754,6 +2754,13 @@ begin
Identifier_Character_Set := Get_Default_Identifier_Character_Set;
Maximum_File_Name_Length := Get_Maximum_File_Name_Length;
-- On VMS, '~' is not allowed in file names. Change the multi unit
-- index character to '$'.
if Hostparm.OpenVMS then
Multi_Unit_Index_Character := '$';
end if;
-- Following should be removed by having above function return
-- Integer'Last as indication of no maximum instead of -1 ???

5
gcc/ada/osint.ads
View File

@ -36,6 +36,11 @@ pragma Elaborate (GNAT.OS_Lib);
package Osint is
Multi_Unit_Index_Character : Character := '~';
-- The character before the index of the unit in a multi-unit source,
-- in ALI and object file names. This is not a constant, because it is
-- changed to '$' on VMS.
Ada_Include_Path : constant String := "ADA_INCLUDE_PATH";
Ada_Objects_Path : constant String := "ADA_OBJECTS_PATH";
Project_Include_Path_File : constant String := "ADA_PRJ_INCLUDE_FILE";

16
gcc/ada/par-ch10.adb
View File

@ -665,11 +665,19 @@ package body Ch10 is
-- Skip tokens to end of file, so that the -gnatl listing
-- will be complete in this situation, but no need to parse
-- the remaining units.
-- the remaining units; no style checking either.
while Token /= Tok_EOF loop
Scan;
end loop;
declare
Save_Style_Check : constant Boolean := Style_Check;
begin
Style_Check := False;
while Token /= Tok_EOF loop
Scan;
end loop;
Style_Check := Save_Style_Check;
end;
return Comp_Unit_Node;

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

@ -2338,16 +2338,8 @@ package body Ch4 is
-- Scan Null_Exclusion if present (Ada 0Y (AI-231))
if Extensions_Allowed then
Null_Exclusion_Present := P_Null_Exclusion;
Set_Null_Exclusion_Present (Alloc_Node, Null_Exclusion_Present);
-- If Ada 95, null exclusion never present
else
Null_Exclusion_Present := False;
end if;
Null_Exclusion_Present := P_Null_Exclusion;
Set_Null_Exclusion_Present (Alloc_Node, Null_Exclusion_Present);
Type_Node := P_Subtype_Mark_Resync;
if Token = Tok_Apostrophe then

94
gcc/ada/par.adb
View File

@ -1233,38 +1233,6 @@ begin
else
Save_Opt_Config_Switches (Save_Config_Switches);
-- Special processing for language defined units. For this purpose
-- we do NOT consider the renamings in annex J as predefined. That
-- allows users to compile their own versions of these files, and
-- in particular, in the VMS implementation, the DEC versions can
-- be substituted for the standard Ada 95 versions.
if Is_Predefined_File_Name
(Fname => File_Name (Current_Source_File),
Renamings_Included => False)
then
Set_Opt_Config_Switches
(Is_Internal_File_Name (File_Name (Current_Source_File)));
-- If this is the main unit, disallow compilation unless the -gnatg
-- (GNAT mode) switch is set (from a user point of view, the rule is
-- that language defined units cannot be recompiled).
-- However, an exception is s-rpc, and its children. We test this
-- by looking at the characters after the minus. The rule is that
-- only s-rpc and its children have names starting s-rp.
Get_Name_String (File_Name (Current_Source_File));
if (Name_Len < 5 or else Name_Buffer (1 .. 4) /= "s-rp")
and then Current_Source_Unit = Main_Unit
and then not GNAT_Mode
and then Operating_Mode = Generate_Code
then
Error_Msg_SC ("language defined units may not be recompiled");
end if;
end if;
-- The following loop runs more than once in syntax check mode
-- where we allow multiple compilation units in the same file
-- and in Multiple_Unit_Per_file mode where we skip units till
@ -1298,10 +1266,15 @@ begin
Save_Operating_Mode : constant Operating_Mode_Type :=
Operating_Mode;
Save_Style_Check : constant Boolean := Style_Check;
begin
Operating_Mode := Check_Syntax;
Style_Check := False;
Discard_Node (P_Compilation_Unit);
Operating_Mode := Save_Operating_Mode;
Style_Check := Save_Style_Check;
-- If we are at an end of file, and not yet at the right
-- unit, then we have a fatal error. The unit is missing.
@ -1317,7 +1290,62 @@ begin
-- check syntax mode we are interested in all units in the file.
else
Discard_Node (P_Compilation_Unit);
declare
Comp_Unit_Node : constant Node_Id := P_Compilation_Unit;
begin
-- If parsing was successful and we are not in check syntax
-- mode, check that language defined units are compiled in
-- GNAT mode. For this purpose we do NOT consider renamings
-- in annex J as predefined. That allows users to compile
-- their own versions of these files, and in particular,
-- in the VMS implementation, the DEC versions can be
-- substituted for the standard Ada 95 versions. Another
-- exception is System.RPC and its children. This allows
-- a user to supply their own communication layer.
if Comp_Unit_Node /= Error
and then Operating_Mode = Generate_Code
and then Current_Source_Unit = Main_Unit
and then not GNAT_Mode
then
declare
Name : constant String :=
Get_Name_String
(Unit_Name (Current_Source_Unit));
begin
if (Name = "ada" or else
Name = "calendar" or else
Name = "interfaces" or else
Name = "system" or else
Name = "machine_code" or else
Name = "unchecked_conversion" or else
Name = "unchecked_deallocation"
or else (Name'Length > 4
and then
Name (Name'First .. Name'First + 3) =
"ada.")
or else (Name'Length > 11
and then
Name (Name'First .. Name'First + 10) =
"interfaces.")
or else (Name'Length > 7
and then
Name (Name'First .. Name'First + 6) =
"system."))
and then Name /= "system.rpc"
and then
(Name'Length < 11
or else Name (Name'First .. Name'First + 10) /=
"system.rpc.")
then
Error_Msg
("language defined units may not be recompiled",
Sloc (Unit (Comp_Unit_Node)));
end if;
end;
end if;
end;
-- All done if at end of file

3
gcc/ada/s-secsta.adb
View File

@ -423,7 +423,8 @@ package body System.Secondary_Stack is
if not SS_Ratio_Dynamic then
declare
Fixed_Stack : Fixed_Stack_Ptr := To_Fixed_Stack_Ptr (Stk);
Fixed_Stack : constant Fixed_Stack_Ptr :=
To_Fixed_Stack_Ptr (Stk);
begin
Fixed_Stack.Top := 0;

2
gcc/ada/s-tpobop.adb
View File

@ -519,7 +519,7 @@ package body System.Tasking.Protected_Objects.Operations is
Mode : Call_Modes;
Block : out Communication_Block)
is
Self_ID : Task_ID := STPO.Self;
Self_ID : constant Task_ID := STPO.Self;
Entry_Call : Entry_Call_Link;
Initially_Abortable : Boolean;
Ceiling_Violation : Boolean;

25
gcc/ada/scng.adb
View File

@ -59,6 +59,9 @@ package body Scng is
-- Local Subprograms --
-----------------------
procedure Accumulate_Token_Checksum;
pragma Inline (Accumulate_Token_Checksum);
procedure Accumulate_Checksum (C : Character);
pragma Inline (Accumulate_Checksum);
-- This routine accumulates the checksum given character C. During the
@ -96,6 +99,17 @@ package body Scng is
Accumulate_Checksum (Character'Val (C mod 256));
end Accumulate_Checksum;
-------------------------------
-- Accumulate_Token_Checksum --
-------------------------------
procedure Accumulate_Token_Checksum is
begin
System.CRC32.Update
(System.CRC32.CRC32 (Checksum),
Character'Val (Token_Type'Pos (Token)));
end Accumulate_Token_Checksum;
----------------------------
-- Determine_Token_Casing --
----------------------------
@ -408,6 +422,7 @@ package body Scng is
-- Procedure to scan integer literal. On entry, Scan_Ptr points to
-- a digit, on exit Scan_Ptr points past the last character of
-- the integer.
--
-- For each digit encountered, UI_Int_Value is multiplied by 10,
-- and the value of the digit added to the result. In addition,
-- the value in Scale is decremented by one for each actual digit
@ -444,7 +459,10 @@ package body Scng is
C := Source (Scan_Ptr);
if C = '_' then
Accumulate_Checksum ('_');
-- We do not want to accumulate the '_' in the checksum,
-- so that 1_234 is equivalent to 1234, and does not
-- trigger compilation in "minimal recompilation"
-- (gnatmake -m).
loop
Scan_Ptr := Scan_Ptr + 1;
@ -707,6 +725,8 @@ package body Scng is
end if;
Accumulate_Token_Checksum;
return;
end Nlit;
@ -2063,16 +2083,19 @@ package body Scng is
-- of the corresponding keyword.
Token_Name := No_Name;
Accumulate_Token_Checksum;
return;
-- It is an identifier after all
else
Token := Tok_Identifier;
Accumulate_Token_Checksum;
Post_Scan;
return;
end if;
end Scan;
--------------------------
-- Set_Comment_As_Token --
--------------------------

12
gcc/ada/sem_ch3.adb
View File

@ -690,24 +690,22 @@ package body Sem_Ch3 is
-- Ada 95 semantics. In Ada 0Y, anonymous access must specify if the
-- null value is allowed; in Ada 95 the null value is not allowed
if Extensions_Allowed
and then Null_Exclusion_Present (N)
then
Set_Can_Never_Be_Null (Anon_Type);
if Extensions_Allowed then
Set_Can_Never_Be_Null (Anon_Type, Null_Exclusion_Present (N));
else
Set_Can_Never_Be_Null (Anon_Type);
Set_Can_Never_Be_Null (Anon_Type, True);
end if;
-- The anonymous access type is as public as the discriminated type or
-- subprogram that defines it. It is imported (for back-end purposes)
-- if the designated type is.
Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type)));
Set_Is_Public (Anon_Type, Is_Public (Scope (Anon_Type)));
-- Ada 0Y (AI-50217): Propagate the attribute that indicates that the
-- designated type comes from the limited view (for back-end purposes).
Set_From_With_Type (Anon_Type, From_With_Type (Desig_Type));
Set_From_With_Type (Anon_Type, From_With_Type (Desig_Type));
-- Ada 0Y (AI-231): Propagate the access-constant attribute

37
gcc/ada/sinfo.ads
View File

@ -1875,7 +1875,7 @@ package Sinfo is
--------------------------------
-- SUBTYPE_DECLARATION ::=
-- subtype DEFINING_IDENTIFIER is SUBTYPE_INDICATION;
-- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION;
-- The subtype indication field is set to Empty for subtypes
-- declared in package Standard (Positive, Natural).
@ -1898,6 +1898,11 @@ package Sinfo is
-- directly in the tree as a subtype mark. The N_Subtype_Indication
-- node is used only if a constraint is present.
-- Note: [For Ada 0Y (AI-231)]: Because Ada 0Y extends this rule with
-- the null-exclusion part (see AI-231), we had to introduce a new
-- attribute in all the parents of subtype_indication nodes to indicate
-- if the null-exclusion is present.
-- Note: the reason that this node has expression fields is that a
-- subtype indication can appear as an operand of a membership test.
@ -1947,7 +1952,7 @@ package Sinfo is
-- OBJECT_DECLARATION ::=
-- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
-- SUBTYPE_INDICATION [:= EXPRESSION];
-- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
-- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
-- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
-- | SINGLE_TASK_DECLARATION
@ -2037,7 +2042,8 @@ package Sinfo is
----------------------------------
-- DERIVED_TYPE_DEFINITION ::=
-- [abstract] new parent_SUBTYPE_INDICATION [RECORD_EXTENSION_PART]
-- [abstract] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
-- [RECORD_EXTENSION_PART]
-- Note: ABSTRACT, record extension part not permitted in Ada 83 mode
@ -2327,7 +2333,7 @@ package Sinfo is
-------------------------------
-- COMPONENT_DEFINITION ::=
-- [aliased] SUBTYPE_INDICATION | ACCESS_DEFINITION
-- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
-- Note: although the syntax does not permit a component definition to
-- be an anonymous array (and the parser will diagnose such an attempt
@ -2398,7 +2404,7 @@ package Sinfo is
-------------------------------------
-- DISCRIMINANT_SPECIFICATION ::=
-- DEFINING_IDENTIFIER_LIST : SUBTYPE_MARK
-- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
-- [:= DEFAULT_EXPRESSION]
-- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
-- [:= DEFAULT_EXPRESSION]
@ -2636,12 +2642,19 @@ package Sinfo is
-- ACCESS_TO_OBJECT_DEFINITION
-- | ACCESS_TO_SUBPROGRAM_DEFINITION
--------------------------
-- 3.10 Null Exclusion --
--------------------------
-- NULL_EXCLUSION ::= not null
---------------------------------------
-- 3.10 Access To Object Definition --
---------------------------------------
-- ACCESS_TO_OBJECT_DEFINITION ::=
-- access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
-- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER]
-- SUBTYPE_INDICATION
-- N_Access_To_Object_Definition
-- Sloc points to ACCESS
@ -2667,8 +2680,9 @@ package Sinfo is
-------------------------------------------
-- ACCESS_TO_SUBPROGRAM_DEFINITION
-- access [protected] procedure PARAMETER_PROFILE
-- | access [protected] function PARAMETER_AND_RESULT_PROFILE
-- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
-- | [NULL_EXCLUSION] access [protected] function
-- PARAMETER_AND_RESULT_PROFILE
-- Note: access to subprograms are not permitted in Ada 83 mode
@ -2689,7 +2703,8 @@ package Sinfo is
-- 3.10 Access Definition --
-----------------------------
-- ACCESS_DEFINITION ::= access SUBTYPE_MARK
-- ACCESS_DEFINITION ::=
-- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
-- N_Access_Definition
-- Sloc points to ACCESS
@ -3485,7 +3500,7 @@ package Sinfo is
--------------------
-- ALLOCATOR ::=
-- new SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION
-- new [NULL_EXCLUSION] SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION
-- Sprint syntax (when storage pool present)
-- new xxx (storage_pool = pool)
@ -3990,7 +4005,7 @@ package Sinfo is
----------------------------------
-- PARAMETER_SPECIFICATION ::=
-- DEFINING_IDENTIFIER_LIST : MODE SUBTYPE_MARK
-- DEFINING_IDENTIFIER_LIST : MODE [NULL_EXCLUSION] SUBTYPE_MARK
-- [:= DEFAULT_EXPRESSION]
-- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
-- [:= DEFAULT_EXPRESSION]

2
gcc/ada/sinput-c.adb
View File

@ -103,7 +103,7 @@ package body Sinput.C is
type Actual_Source_Ptr is access Actual_Source_Buffer;
-- This is the pointer type for the physical buffer allocated
Actual_Ptr : Actual_Source_Ptr := new Actual_Source_Buffer;
Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer;
-- And this is the actual physical buffer
begin

12
gcc/ada/switch-c.adb
View File

@ -220,12 +220,6 @@ package body Switch.C is
ASIS_Mode := True;
end if;
-- Processing for C switch
when 'C' =>
Ptr := Ptr + 1;
Scan_Pos (Switch_Chars, 999, Ptr, Multiple_Unit_Index);
-- Processing for d switch
when 'd' =>
@ -388,6 +382,12 @@ package body Switch.C is
Full_Path_Name_For_Brief_Errors := True;
return;
-- -gnateI (index of unit in multi-unit source)
when 'I' =>
Ptr := Ptr + 1;
Scan_Pos (Switch_Chars, 999, Ptr, Multiple_Unit_Index);
-- -gnatem (mapping file)
when 'm' =>

21
gcc/ada/switch-m.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
-- Copyright (C) 2001-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- --
@ -86,8 +86,9 @@ package body Switch.M is
elsif Last = Switches'Last then
declare
New_Switches : Argument_List_Access := new Argument_List
(1 .. Switches'Length + Switches'Length);
New_Switches : constant Argument_List_Access :=
new Argument_List
(1 .. Switches'Length + Switches'Length);
begin
New_Switches (1 .. Switches'Length) := Switches.all;
Last := Switches'Length;
@ -96,9 +97,9 @@ package body Switch.M is
end if;
-- If this is the first switch, Last designates the first component
if Last = 0 then
Last := Switches'First;
else
Last := Last + 1;
end if;
@ -225,8 +226,7 @@ package body Switch.M is
when 'e' =>
-- Only -gnateD and -gnatep= need to be store in an ALI
-- file.
-- Only -gnateD and -gnatep= need storing in ALI file
Storing (First_Stored) := 'e';
Ptr := Ptr + 1;
@ -239,9 +239,9 @@ package body Switch.M is
return;
end if;
if Switch_Chars (Ptr) = 'D' then
-- gnateD
-- Processing for -gnateD
if Switch_Chars (Ptr) = 'D' then
Storing (First_Stored + 1 ..
First_Stored + Max - Ptr + 1) :=
Switch_Chars (Ptr .. Max);
@ -249,9 +249,9 @@ package body Switch.M is
(Storing (Storing'First ..
First_Stored + Max - Ptr + 1));
else
-- gnatep=
-- Processing for -gnatep=
else
Ptr := Ptr + 1;
if Ptr = Max then
@ -269,7 +269,6 @@ package body Switch.M is
declare
To_Store : String (1 .. Max - Ptr + 9);
begin
To_Store (1 .. 8) := "-gnatep=";
To_Store (9 .. Max - Ptr + 9) :=

5
gcc/ada/usage.adb
View File

@ -159,6 +159,11 @@ begin
Write_Switch_Char ("ef");
Write_Line ("Full source path in brief error messages");
-- Line for -gnateI switch
Write_Switch_Char ("eInnn");
Write_Line ("Index in multi-unit source, e.g. -gnateI2");
-- Line for -gnatem switch
Write_Switch_Char ("em=?");