diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2004-04-01 10:04:40 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2004-04-01 10:04:40 +0000 |
| commit | 314a23b6eb1ed66ddce188a8e105c8050b99b87e (patch) | |
| tree | b338d3df4e73cbb9b9be4f8a5366b15275287114 /gcc/ada | |
| parent | ac7a21466424c6756e6670dd1943d67497962ac1 (diff) | |
| download | gcc-314a23b6eb1ed66ddce188a8e105c8050b99b87e.tar.gz | |
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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@80290 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
33 files changed, 509 insertions, 394 deletions
diff --git a/gcc/ada/56taprop.adb b/gcc/ada/56taprop.adb index b4098264262..6276d7f5092 100644 --- a/gcc/ada/56taprop.adb +++ b/gcc/ada/56taprop.adb @@ -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; diff --git a/gcc/ada/5ginterr.adb b/gcc/ada/5ginterr.adb index fd3f9c05013..4ee53e00b09 100644 --- a/gcc/ada/5ginterr.adb +++ b/gcc/ada/5ginterr.adb @@ -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 diff --git a/gcc/ada/5gmastop.adb b/gcc/ada/5gmastop.adb index 480e3ead130..d75bf326b7a 100644 --- a/gcc/ada/5gmastop.adb +++ b/gcc/ada/5gmastop.adb @@ -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"); diff --git a/gcc/ada/5staprop.adb b/gcc/ada/5staprop.adb index 0242b0aefa8..a264b029693 100644 --- a/gcc/ada/5staprop.adb +++ b/gcc/ada/5staprop.adb @@ -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 diff --git a/gcc/ada/5vinterr.adb b/gcc/ada/5vinterr.adb index f41f6542f92..f302ead12e3 100644 --- a/gcc/ada/5vinterr.adb +++ b/gcc/ada/5vinterr.adb @@ -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; diff --git a/gcc/ada/5vtaprop.adb b/gcc/ada/5vtaprop.adb index fd6c98baefa..5a7739d3abc 100644 --- a/gcc/ada/5vtaprop.adb +++ b/gcc/ada/5vtaprop.adb @@ -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); diff --git a/gcc/ada/5vtpopde.adb b/gcc/ada/5vtpopde.adb index 001507a07a2..89db8240ad8 100644 --- a/gcc/ada/5vtpopde.adb +++ b/gcc/ada/5vtpopde.adb @@ -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); diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5fe33e42659..fb80339b23b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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): diff --git a/gcc/ada/Make-lang.in b/gcc/ada/Make-lang.in index 419fd0b4b1d..e7702aaa3ea 100644 --- a/gcc/ada/Make-lang.in +++ b/gcc/ada/Make-lang.in @@ -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 \ diff --git a/gcc/ada/a-tasatt.adb b/gcc/ada/a-tasatt.adb index 873b3870409..f68c6255a86 100644 --- a/gcc/ada/a-tasatt.adb +++ b/gcc/ada/a-tasatt.adb @@ -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 diff --git a/gcc/ada/ali-util.adb b/gcc/ada/ali-util.adb index 2d5ed8d4ab8..07ed8f14c44 100644 --- a/gcc/ada/ali-util.adb +++ b/gcc/ada/ali-util.adb @@ -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; - ----------------------- - -- 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 + pragma Warnings (Off); + -- To avoid warnings on non referenced parameters of the error procedures - use ASCII; - -- Make control characters visible + --------------- + -- Error_Msg -- + --------------- + procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is begin - Read_Source_File (Fname, 0, Hi, Src); - - -- 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; - end if; - - Initialize_Checksum (Csum); - Ptr := 0; - - 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; + null; + end Error_Msg; - -- Non-blank characters that are included in the checksum + pragma Warnings (Off); + -- To avoid warnings on non referenced parameters of the error procedures - when '#' | '&' | '*' | ':' | '(' | ',' | '.' | '=' | '>' | - '<' | ')' | '/' | ';' | '|' | '!' | '+' | '_' | - '0' .. '9' | 'a' .. 'z' - => - Accumulate_Checksum (Src (Ptr), Csum); - Ptr := Ptr + 1; + ----------------- + -- Error_Msg_S -- + ----------------- - -- 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; + procedure Error_Msg_S (Msg : String) is + begin + null; + end Error_Msg_S; - Accumulate_Checksum (Src (Ptr), Csum); - end loop; + ------------------ + -- Error_Msg_SC -- + ------------------ - Accumulate_Checksum ('%', Csum); - Ptr := Ptr + 1; + procedure Error_Msg_SC (Msg : String) is + begin + null; + end Error_Msg_SC; - -- Quote, could be character constant + ------------------ + -- Error_Msg_SP -- + ------------------ - when ''' => - Accumulate_Checksum (''', Csum); + procedure Error_Msg_SP (Msg : String) is + begin + null; + end Error_Msg_SP; - if Src (Ptr + 2) = ''' then - Accumulate_Checksum (Src (Ptr + 1), Csum); - Accumulate_Checksum (''', Csum); - Ptr := Ptr + 3; + pragma Warnings (On); - -- Otherwise assume attribute char. We should deal with wide - -- character cases here, but that's hard, so forget it. + ----------------------- + -- Get_File_Checksum -- + ----------------------- - else - Ptr := Ptr + 1; - end if; + function Get_File_Checksum (Fname : Name_Id) return Word is + Full_Name : Name_Id; + Source_Index : Source_File_Index; + begin + Full_Name := Find_File (Fname, Osint.Source); - -- 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. + -- 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. - when Upper_Half_Character => - Accumulate_Checksum (Src (Ptr), Csum); - Ptr := Ptr + 1; + if Full_Name = No_File then + return Checksum_Error; + end if; - -- Escape character, we should do the wide character thing here, - -- but for now, do not bother. + Source_Index := Sinput.C.Load_File (Get_Name_String (Full_Name)); - when ESC => - raise Bad; + if Source_Index = No_Source_File then + return Checksum_Error; + end if; - -- Invalid control characters + Scanner.Initialize_Scanner (Types.No_Unit, Source_Index); - 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; + -- 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. - -- Invalid graphic characters + Set_Name_Table_Byte (Name_Project, 0); + Set_Name_Table_Byte (Name_Extends, 0); + Set_Name_Table_Byte (Name_External, 0); - when '$' | '?' | '@' | '`' | '\' | - '^' | '~' | ']' | '{' | '}' - => - raise Bad; + -- Scan the complete file to compute its checksum - end case; + loop + 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 -- diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index b16fcc18c2f..ea73f2f8d4f 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -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 diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 7b9e48254b9..37d9a618da6 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -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; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index e1440f2ead6..c9de061ec58 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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; diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index 416712712bb..b86d353ea6a 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -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); diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb index 8a4f19b0419..05862b478eb 100644 --- a/gcc/ada/g-comlin.adb +++ b/gcc/ada/g-comlin.adb @@ -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; diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index bb65a0f95a6..83313755ba7 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -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 diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 15d6ed01b3e..89b0d69a739 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -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; diff --git a/gcc/ada/osint-c.adb b/gcc/ada/osint-c.adb index 7914b1b3805..a8b02690185 100644 --- a/gcc/ada/osint-c.adb +++ b/gcc/ada/osint-c.adb @@ -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); diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index fcf4e13289d..07355ed9ba2 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -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 ??? diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads index 0e87e9a4948..44ad5bad4ed 100644 --- a/gcc/ada/osint.ads +++ b/gcc/ada/osint.ads @@ -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"; diff --git a/gcc/ada/par-ch10.adb b/gcc/ada/par-ch10.adb index 985d9e328cc..97d4c362daa 100644 --- a/gcc/ada/par-ch10.adb +++ b/gcc/ada/par-ch10.adb @@ -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; diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index b56c8b0b6c8..791a866c95f 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -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 diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 1a1d9750a96..dbec0b8ff26 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -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 diff --git a/gcc/ada/s-secsta.adb b/gcc/ada/s-secsta.adb index 449d986d511..f88589d8324 100644 --- a/gcc/ada/s-secsta.adb +++ b/gcc/ada/s-secsta.adb @@ -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; diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb index fde749e9eef..a77fb63a3ba 100644 --- a/gcc/ada/s-tpobop.adb +++ b/gcc/ada/s-tpobop.adb @@ -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; diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index f0189c1428b..690656c76fb 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -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 -- -------------------------- diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index b17f870ae12..1c33c4ab582 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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 diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index c6ea9e86316..7f35f5c384a 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -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] diff --git a/gcc/ada/sinput-c.adb b/gcc/ada/sinput-c.adb index 370429a0109..2553cedee40 100644 --- a/gcc/ada/sinput-c.adb +++ b/gcc/ada/sinput-c.adb @@ -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 diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index fab690a2a2f..df91201a7ae 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -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' => diff --git a/gcc/ada/switch-m.adb b/gcc/ada/switch-m.adb index 9f37e0365a3..4001ba86a89 100644 --- a/gcc/ada/switch-m.adb +++ b/gcc/ada/switch-m.adb @@ -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) := diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index f6dea3e7a2a..3adf3044049 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -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=?"); |