diff options
| author | Arnaud Charlet <charlet@gcc.gnu.org> | 2004-01-05 16:20:47 +0100 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2004-01-05 16:20:47 +0100 |
| commit | 91b1417d44eb5b73dcb10ce26ecc779b24e8d00d (patch) | |
| tree | 4e026dfac036b969e00a952b33c9f32df5724609 | |
| parent | 1e2d4dc10521dd508ab4b9405e5a14f15343bf8d (diff) | |
| download | gcc-91b1417d44eb5b73dcb10ce26ecc779b24e8d00d.zip gcc-91b1417d44eb5b73dcb10ce26ecc779b24e8d00d.tar.gz gcc-91b1417d44eb5b73dcb10ce26ecc779b24e8d00d.tar.bz2 | |
[multiple changes]
2004-01-05 Robert Dewar <dewar@gnat.com>
* 1ssecsta.ads: Default_Secondary_Stack is not a constant since it may
be modified by the binder generated main program if the -D switch is
used.
* 4onumaux.ads, 4znumaux.ads: Add Pure_Function pragmas for all
imported functions (since now we expect this to be done for imported
functions)
* 5vtaprop.adb: Add several ??? for sections requiring more comments
Minor reformatting throughout
* 5zinit.adb: Minor reformatting
Add 2004 to copyright date
Minor changes to avoid -gnatwa warnings
Correct some instances of using OR instead of OR ELSE (noted while
doing reformatting)
* sprint.adb: Minor updates to avoid -gnatwa warnings
* s-secsta.ads, s-secsta.adb:
(SS_Get_Max): New function to obtain high water mark for ss stack
Default_Secondary_Stack is not a constant since it may be modified by
the binder generated main program if the -D switch is used.
* switch-b.adb: New -Dnnn switch for binder
* switch-c.adb:
Make -gnatg imply all warnings currently in -gnatwa
* vms_conv.adb: Minor reformatting
Add 2004 to copyright notice
Add 2004 to printed copyright notice
* 3vexpect.adb, 4zsytaco.adb, 3wsocthi.adb, 3zsocthi.adb,
3zsocthi.adb, 56taprop.adb, 56tpopsp.adb, 5amastop.adb,
5aml-tgt.adb, 5ataprop.adb, 5ataprop.adb, 5atpopsp.adb,
5ftaprop.adb, 5ginterr.adb, 5gmastop.adb, 5gml-tgt.adb,
5gtaprop.adb, 5hml-tgt.adb, 5hml-tgt.adb, 5hml-tgt.adb,
5htaprop.adb, 5htraceb.adb, 5itaprop.adb, 5lml-tgt.adb,
5sml-tgt.adb, 5staprop.adb, 5staprop.adb, 5stpopsp.adb,
5vasthan.adb, 5vinmaop.adb, 5vinterr.adb, 5vtaprop.adb,
5vml-tgt.adb, 5vtaprop.adb, 5wosprim.adb, 5wtaprop.adb,
5zinterr.adb, 5zintman.adb, 5zml-tgt.adb, 5ztaprop.adb,
6vcpp.adb, 6vcstrea.adb, 7staprop.adb, 7stpopsp.adb,
vxaddr2line.adb, vxaddr2line.adb, xref_lib.adb, xr_tabls.adb,
xr_tabls.ads, s-tasdeb.adb, s-tasdeb.adb, sem_res.ads,
sem_util.adb, sem_util.adb, sem_util.ads, s-interr.adb,
checks.adb, clean.adb, cstand.adb, einfo.ads,
einfo.adb, exp_aggr.adb, exp_ch11.adb, exp_ch3.adb,
exp_ch4.adb, exp_ch5.adb, exp_ch7.adb, exp_ch9.adb,
prj-nmsc.adb, prj-pp.adb, prj-util.adb, sem_attr.adb,
sem_ch10.adb, sem_ch12.adb, sem_ch4.adb, g-dirope.adb,
g-dirope.ads, gnatlbr.adb, i-cstrea.adb, inline.adb,
lib-xref.adb, sem_ch5.adb, sem_ch7.adb, sem_ch8.adb:
Minor reformatting and code clean ups.
Minor changes to prevent -gnatwa warnings
* ali.adb: Minor reformatting and cleanup of code
Acquire new SS indication of secondary stack use from ali files
* a-numaux.ads: Add Pure_Function pragmas for all imported functions
(since now we expect this to be done for imported functions)
* bindgen.adb: Generate call to modify default secondary stack size if
-Dnnn switch given
* bindusg.adb: Add line for new -D switch
* exp_aggr.adb (Type_May_Have_Bit_Aligned_Components): More appropriate
replacement name for Type_May_Have_Non_Bit_Aligned_Components!
Add circuitry for both records and arrays to avoid gigi
processing if the type involved has non-bit-aligned components
* exp_ch5.adb (Expand_Assign_Array): Avoid assumption that
N_String_Literal node always references an E_String_Literal_Subtype
entity. This may not be true in the future.
(Possible_Bit_Aligned_Component): Move processing of
Component_May_Be_Bit_Aligned from exp_ch5 to exp_util
* exp_ch6.adb (Expand_Thread_Body): Pick up
Default_Secondary_Stack_Size as variable so that we get value modified
by possible -Dnnn binder parameter.
* exp_util.adb (Component_May_Be_Bit_Aligned): New function.
(Type_May_Have_Bit_Aligned_Components): New function.
* exp_util.ads (Component_May_Be_Bit_Aligned): New function.
(Type_May_Have_Bit_Aligned_Components): New function.
* fe.h: (Set_Identifier_Casing): Fix prototype.
Add declaration for Sem_Elim.Eliminate_Error_Msg.
Minor reformatting.
* freeze.adb (Freeze_Entity): Add RM reference to error message about
importing constant atomic/volatile objects.
(Freeze_Subprogram): Reset Is_Pure indication for imported subprogram
unless explicit Pure_Function pragma given, to avoid insidious bug of
call to non-pure imported function getting eliminated.
* gnat1drv.adb, gnatbind.adb, gnatchop.adb, gnatfind.adb,
gnatls.adb, gnatlink.adb, gnatmem.adb, gnatname.adb, gnatsym.adb,
gnatxref.adb, gprcmd.adb, gprep.adb, make.adb: Minor reformatting
Add 2004 to printed copyright notice
* lib-writ.ads, lib-writ.adb: Put new SS flag in ali file if secondary
stack used.
* Makefile.rtl: Add entry for g-sestin.o
g-sestin.ads: New file.
* mdll.adb: Minor changes to avoid -gnatwa warnings
* mlib-tgt.adb: Minor reformatting
* opt.ads: New parameter Default_Secondary_Stack_Size (GNATBIND)
New switch Sec_Stack_Used (GNAT, GNATBIND)
Make Default_Secondary_Stack_Size a variable instead of a constant,
so that it can be modified by the new -Dnnn bind switch.
* rtsfind.adb (Load_Fail): Give full error message in configurable
run-time mode if all_errors mode is set. This was not done in the case
of a file not found, which was an oversight.
Note if secondary stack unit is used by compiler.
* sem_elab.adb (Check_A_Call): Rewrite to avoid trying to put
ineffective elaborate all pragmas on non-visible packages (this
happened when a renamed subprogram was called). Now the elaborate all
always goes on the package containing the renaming rather than the one
containing the renamed subprogram.
* sem_elim.ads, sem_elim.adb (Eliminate_Error_Msg): New procedure
(Process_Eliminate_Pragma): Add parameter to capture pragma location.
* sem_eval.adb (Eval_String_Literal): Do not assume that string literal
has an Etype that references an E_String_Literal.
(Eval_String_Literal): Avoid assumption that N_String_Literal node
always references an E_String_Literal_Subtype entity. This may not
be true in the future.
* sem_prag.adb (Process_Eliminate_Pragma): Add parameter to capture
pragma location.
* sem_res.adb (Resolve): Specialize msg for function name used in proc
call.
2004-01-05 Ed Falis <falis@gnat.com>
* g-debuti.adb: Replaced direct boolean operator with short-circuit
form.
2004-01-05 Vincent Celier <celier@gnat.com>
* bld.adb: Minor comment updates
(Process_Declarative_Items): Correct incorrect name (Index_Name instead
of Item_Name).
* make.adb (Gnatmake): Special process for files to compile/check when
-B is specified. Fail when there are only foreign mains in attribute
Main of the project file and -B is not specified. Do not skip bind/link
steps when -B is specified.
* makeusg.adb: Document new switch -B
* opt.ads (Build_Bind_And_Link_Full_Project): New Boolean flag
* switch-m.adb: (Scan_Make_Switches): Process -B switch
* vms_data.ads: Add new GNAT PRETTY qualifier
/FORM_FEED_AFTER_PRAGMA_PAGE for switch -ff
2004-01-05 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* trans.c (tree_transform, case N_Free_Statement): Handle thin pointer
case.
* misc.c (gnat_printable_name): If VERBOSITY is 2, call
Set_Identifier_Casing.
* decl.c (gnat_to_gnu_entity, E_Function): Give error if return type
has size that overflows.
2004-01-05 Gary Dismukes <dismukes@gnat.com>
* exp_ch4.adb (Expand_Array_Comparison): Add Boolean constant to avoid
-gnatwa warning on static condition.
2004-01-05 Doug Rupp <rupp@gnat.com>
* link.c: (shared_libgnat_default) [VMS]: Change to STATIC.
2004-01-05 Arnaud Charlet <charlet@act-europe.fr>
* Makefile.in: Install ali files using INSTALL_DATA_DATE to preserve
all attributes, including read-only attribute.
2004-01-05 Pascal Obry <obry@gnat.com>
* bindgen.adb (Gen_Object_Files_Options): Generate the new shared
library naming scheme.
* mlib-prj.adb (Build_Library): Generate different names for the static
or dynamic version of the GNAT runtime. This is needed to support the
new shared library naming scheme.
(Process_Binder_File): Add detection of shared library in binder file
based on the new naming scheme.
* gnatlink.adb (Process_Binder_File): Properly detect the new naming
scheme for the shared runtime libraries.
* Makefile.in:
(LIBRARY_VERSION) [VMS]: Convert all . to _ to conform to new naming
scheme.
(install-gnatlib): Do not create symlinks for shared libraries.
(gnatlib-shared-default): Idem.
(gnatlib-shared-dual-win32): New target. Not used for now as the
auto-import feature does not support arrays/records.
(gnatlib-shared-win32): Do not create copy for the shared libraries.
(gnatlib-shared-vms): Fix shared runtime libraries names.
* osint.ads, osint.adb (Shared_Lib): New routine, returns the target
dependent runtime shared library name.
2004-01-05 Vasiliy Fofanov <fofanov@act-europe.fr>
* osint.adb (Read_Library_Info): Remove bogus check if ALI is older
than the object.
2004-01-05 Ed Schonberg <schonberg@gnat.com>
* sem_ch4.adb (Analyze_Allocator): Check restriction on dynamic
protected objects when allocator has a subtype indication, not a
qualified expression. Note that qualified expressions may have to be
checked when limited aggregates are implemented.
* sem_prag.adb (Analyze_Pragma, case Import): If enclosing package is
pure, emit warning.
(Analyze_Pragma, case Pure_Function): If enclosing package is pure and
subprogram is imported, remove warning.
2004-01-05 Geert Bosch <bosch@gnat.com>
* s-poosiz.adb: Update copyright notice.
(Allocate): Use Task_Lock to protect against concurrent access.
(Deallocate): Likewise.
2004-01-05 Joel Brobecker <brobecker@gnat.com>
* s-stalib.adb (Elab_Final_Code): Add missing year in date inside ???
comment.
From-SVN: r75432
137 files changed, 2489 insertions, 1395 deletions
diff --git a/gcc/ada/1ssecsta.ads b/gcc/ada/1ssecsta.ads index 2d1bbe4..1da66e8 100644 --- a/gcc/ada/1ssecsta.ads +++ b/gcc/ada/1ssecsta.ads @@ -39,8 +39,8 @@ package System.Secondary_Stack is package SSE renames System.Storage_Elements; - Default_Secondary_Stack_Size : constant := 10 * 1024; - -- Default size of a secondary stack + Default_Secondary_Stack_Size : Natural := 10 * 1024; + -- Default size of a secondary stack. May be modified by binder -D switch procedure SS_Init (Stk : System.Address; diff --git a/gcc/ada/3vexpect.adb b/gcc/ada/3vexpect.adb index fd239a5..1f18885 100644 --- a/gcc/ada/3vexpect.adb +++ b/gcc/ada/3vexpect.adb @@ -102,8 +102,7 @@ package body GNAT.Expect is (Fds : System.Address; Num_Fds : Integer; Timeout : Integer; - Is_Set : System.Address) - return Integer; + Is_Set : System.Address) return Integer; pragma Import (C, Poll, "__gnat_expect_poll"); -- Check whether there is any data waiting on the file descriptor -- Out_fd, and wait if there is none, at most Timeout milliseconds @@ -130,8 +129,7 @@ package body GNAT.Expect is --------- function "+" - (P : GNAT.Regpat.Pattern_Matcher) - return Pattern_Matcher_Access + (P : GNAT.Regpat.Pattern_Matcher) return Pattern_Matcher_Access is begin return new GNAT.Regpat.Pattern_Matcher'(P); @@ -768,8 +766,7 @@ package body GNAT.Expect is ------------------ function Get_Error_Fd - (Descriptor : Process_Descriptor) - return GNAT.OS_Lib.File_Descriptor + (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor is begin return Descriptor.Error_Fd; @@ -780,8 +777,7 @@ package body GNAT.Expect is ------------------ function Get_Input_Fd - (Descriptor : Process_Descriptor) - return GNAT.OS_Lib.File_Descriptor + (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor is begin return Descriptor.Input_Fd; @@ -792,8 +788,7 @@ package body GNAT.Expect is ------------------- function Get_Output_Fd - (Descriptor : Process_Descriptor) - return GNAT.OS_Lib.File_Descriptor + (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor is begin return Descriptor.Output_Fd; @@ -804,8 +799,7 @@ package body GNAT.Expect is ------------- function Get_Pid - (Descriptor : Process_Descriptor) - return Process_Id + (Descriptor : Process_Descriptor) return Process_Id is begin return Descriptor.Pid; @@ -848,8 +842,8 @@ package body GNAT.Expect is function Get_Vfork_Jmpbuf return System.Address; pragma Import (C, Get_Vfork_Jmpbuf, "decc$$get_vfork_jmpbuf"); - function Get_Current_Invo_Context (Addr : System.Address) - return Process_Id; + function Get_Current_Invo_Context + (Addr : System.Address) return Process_Id; pragma Import (C, Get_Current_Invo_Context, "LIB$GET_CURRENT_INVO_CONTEXT"); @@ -1003,21 +997,23 @@ package body GNAT.Expect is ---------- procedure Send - (Descriptor : in out Process_Descriptor; - Str : String; - Add_LF : Boolean := True; + (Descriptor : in out Process_Descriptor; + Str : String; + Add_LF : Boolean := True; Empty_Buffer : Boolean := False) is - N : Natural; Full_Str : constant String := Str & ASCII.LF; Last : Natural; Result : Expect_Match; Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); + Discard : Natural; + pragma Unreferenced (Discard); + begin if Empty_Buffer then - -- Force a read on the process if there is anything waiting. + -- Force a read on the process if there is anything waiting Expect_Internal (Descriptors, Result, Timeout => 0, Full_Buffer => False); @@ -1036,9 +1032,10 @@ package body GNAT.Expect is Call_Filters (Descriptor, Full_Str (Full_Str'First .. Last), Input); - N := Write (Descriptor.Input_Fd, - Full_Str'Address, - Last - Full_Str'First + 1); + Discard := Write (Descriptor.Input_Fd, + Full_Str'Address, + Last - Full_Str'First + 1); + -- Shouldn't we at least have a pragma Assert on the result ??? end Send; ----------------- diff --git a/gcc/ada/3wsocthi.adb b/gcc/ada/3wsocthi.adb index 0fb9731..601c7b5 100644 --- a/gcc/ada/3wsocthi.adb +++ b/gcc/ada/3wsocthi.adb @@ -143,8 +143,8 @@ package body GNAT.Sockets.Thin is is pragma Warnings (Off, Exceptfds); - RFS : Fd_Set_Access := Readfds; - WFS : Fd_Set_Access := Writefds; + RFS : constant Fd_Set_Access := Readfds; + WFS : constant Fd_Set_Access := Writefds; WFSC : Fd_Set_Access := No_Fd_Set; EFS : Fd_Set_Access := Exceptfds; Res : C.int; @@ -190,10 +190,10 @@ package body GNAT.Sockets.Thin is if EFS /= No_Fd_Set then declare - EFSC : Fd_Set_Access := New_Socket_Set (EFS); + EFSC : constant Fd_Set_Access := New_Socket_Set (EFS); + Flag : constant C.int := MSG_PEEK + MSG_OOB; Buffer : Character; Length : C.int; - Flag : C.int := MSG_PEEK + MSG_OOB; Fromlen : aliased C.int; begin diff --git a/gcc/ada/3zsocthi.adb b/gcc/ada/3zsocthi.adb index c40e352..92788e6 100644 --- a/gcc/ada/3zsocthi.adb +++ b/gcc/ada/3zsocthi.adb @@ -45,7 +45,8 @@ with Unchecked_Conversion; package body GNAT.Sockets.Thin is - Non_Blocking_Sockets : Fd_Set_Access := New_Socket_Set (No_Socket_Set); + Non_Blocking_Sockets : constant Fd_Set_Access := + New_Socket_Set (No_Socket_Set); -- When this package is initialized with Process_Blocking_IO set -- to True, sockets are set in non-blocking mode to avoid blocking -- the whole process when a thread wants to perform a blocking IO @@ -59,6 +60,7 @@ package body GNAT.Sockets.Thin is -- When Thread_Blocking_IO is False, we set sockets in -- non-blocking mode and we spend a period of time Quantum between -- two attempts on a blocking operation. + Thread_Blocking_IO : Boolean := True; -- The following types and variables are required to create a Hostent @@ -66,17 +68,17 @@ package body GNAT.Sockets.Thin is type In_Addr_Access_Array_Access is access In_Addr_Access_Array; - Alias_Access : Chars_Ptr_Pointers.Pointer := + Alias_Access : constant Chars_Ptr_Pointers.Pointer := new C.Strings.chars_ptr'(C.Strings.Null_Ptr); - In_Addr_Access_Array_A : In_Addr_Access_Array_Access := + In_Addr_Access_Array_A : constant In_Addr_Access_Array_Access := new In_Addr_Access_Array'(new In_Addr, null); - In_Addr_Access_Ptr : In_Addr_Access_Pointers.Pointer := + In_Addr_Access_Ptr : constant In_Addr_Access_Pointers.Pointer := In_Addr_Access_Array_A (In_Addr_Access_Array_A'First)'Access; - Local_Hostent : Hostent_Access := new Hostent; + Local_Hostent : constant Hostent_Access := new Hostent; ----------------------- -- Local Subprograms -- @@ -87,30 +89,26 @@ package body GNAT.Sockets.Thin is function Syscall_Accept (S : C.int; Addr : System.Address; - Addrlen : access C.int) - return C.int; + Addrlen : access C.int) return C.int; pragma Import (C, Syscall_Accept, "accept"); function Syscall_Connect (S : C.int; Name : System.Address; - Namelen : C.int) - return C.int; + Namelen : C.int) return C.int; pragma Import (C, Syscall_Connect, "connect"); function Syscall_Ioctl (S : C.int; Req : C.int; - Arg : Int_Access) - return C.int; + Arg : Int_Access) return C.int; pragma Import (C, Syscall_Ioctl, "ioctl"); function Syscall_Recv (S : C.int; Msg : System.Address; Len : C.int; - Flags : C.int) - return C.int; + Flags : C.int) return C.int; pragma Import (C, Syscall_Recv, "recv"); function Syscall_Recvfrom @@ -119,16 +117,14 @@ package body GNAT.Sockets.Thin is Len : C.int; Flags : C.int; From : Sockaddr_In_Access; - Fromlen : access C.int) - return C.int; + Fromlen : access C.int) return C.int; pragma Import (C, Syscall_Recvfrom, "recvfrom"); function Syscall_Send (S : C.int; Msg : System.Address; Len : C.int; - Flags : C.int) - return C.int; + Flags : C.int) return C.int; pragma Import (C, Syscall_Send, "send"); function Syscall_Sendto @@ -137,15 +133,13 @@ package body GNAT.Sockets.Thin is Len : C.int; Flags : C.int; To : Sockaddr_In_Access; - Tolen : C.int) - return C.int; + Tolen : C.int) return C.int; pragma Import (C, Syscall_Sendto, "sendto"); function Syscall_Socket (Domain : C.int; Typ : C.int; - Protocol : C.int) - return C.int; + Protocol : C.int) return C.int; pragma Import (C, Syscall_Socket, "socket"); function Non_Blocking_Socket (S : C.int) return Boolean; @@ -158,12 +152,13 @@ package body GNAT.Sockets.Thin is function C_Accept (S : C.int; Addr : System.Address; - Addrlen : access C.int) - return C.int + Addrlen : access C.int) return C.int is R : C.int; Val : aliased C.int := 1; + Res : C.int; + pragma Unreferenced (Res); begin loop @@ -184,6 +179,7 @@ package body GNAT.Sockets.Thin is Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access); + -- Is it OK to ignore result ??? end if; return R; @@ -196,8 +192,7 @@ package body GNAT.Sockets.Thin is function C_Connect (S : C.int; Name : System.Address; - Namelen : C.int) - return C.int + Namelen : C.int) return C.int is Res : C.int; @@ -260,8 +255,7 @@ package body GNAT.Sockets.Thin is function C_Gethostbyaddr (Addr : System.Address; Len : C.int; - Typ : C.int) - return Hostent_Access + Typ : C.int) return Hostent_Access is pragma Warnings (Off, Len); pragma Warnings (Off, Typ); @@ -290,12 +284,10 @@ package body GNAT.Sockets.Thin is --------------------- function C_Gethostbyname - (Name : C.char_array) - return Hostent_Access + (Name : C.char_array) return Hostent_Access is function VxWorks_Gethostbyname - (Name : C.char_array) - return C.int; + (Name : C.char_array) return C.int; pragma Import (C, VxWorks_Gethostbyname, "hostGetByName"); Addr : C.int; @@ -315,8 +307,7 @@ package body GNAT.Sockets.Thin is function C_Getservbyname (Name : C.char_array; - Proto : C.char_array) - return Servent_Access + Proto : C.char_array) return Servent_Access is pragma Warnings (Off, Name); pragma Warnings (Off, Proto); @@ -331,8 +322,7 @@ package body GNAT.Sockets.Thin is function C_Getservbyport (Port : C.int; - Proto : C.char_array) - return Servent_Access + Proto : C.char_array) return Servent_Access is pragma Warnings (Off, Port); pragma Warnings (Off, Proto); @@ -348,8 +338,7 @@ package body GNAT.Sockets.Thin is function C_Ioctl (S : C.int; Req : C.int; - Arg : Int_Access) - return C.int + Arg : Int_Access) return C.int is begin if not Thread_Blocking_IO @@ -371,8 +360,7 @@ package body GNAT.Sockets.Thin is (S : C.int; Msg : System.Address; Len : C.int; - Flags : C.int) - return C.int + Flags : C.int) return C.int is Res : C.int; @@ -399,8 +387,7 @@ package body GNAT.Sockets.Thin is Len : C.int; Flags : C.int; From : Sockaddr_In_Access; - Fromlen : access C.int) - return C.int + Fromlen : access C.int) return C.int is Res : C.int; @@ -425,8 +412,7 @@ package body GNAT.Sockets.Thin is (S : C.int; Msg : System.Address; Len : C.int; - Flags : C.int) - return C.int + Flags : C.int) return C.int is Res : C.int; @@ -453,8 +439,7 @@ package body GNAT.Sockets.Thin is Len : C.int; Flags : C.int; To : Sockaddr_In_Access; - Tolen : C.int) - return C.int + Tolen : C.int) return C.int is Res : C.int; @@ -478,12 +463,13 @@ package body GNAT.Sockets.Thin is function C_Socket (Domain : C.int; Typ : C.int; - Protocol : C.int) - return C.int + Protocol : C.int) return C.int is R : C.int; Val : aliased C.int := 1; + Res : C.int; + pragma Unreferenced (Res); begin R := Syscall_Socket (Domain, Typ, Protocol); @@ -495,6 +481,7 @@ package body GNAT.Sockets.Thin is -- in non-blocking mode by user. Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access); + -- Is it OK to ignore result ??? Set_Non_Blocking_Socket (R, False); end if; @@ -611,7 +598,6 @@ package body GNAT.Sockets.Thin is if C_Msg = C.Strings.Null_Ptr then return "Unknown system error"; - else return C.Strings.Value (C_Msg); end if; diff --git a/gcc/ada/4onumaux.ads b/gcc/ada/4onumaux.ads index 1512401..0f84a9f 100644 --- a/gcc/ada/4onumaux.ads +++ b/gcc/ada/4onumaux.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (C Library Version for x86) -- -- -- --- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2003 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- -- @@ -50,43 +50,59 @@ pragma Pure (Aux); type Double is digits 18; + -- We import these functions directly from C. Note that we label them + -- all as pure functions, because indeed all of them are in fact pure! + function Sin (X : Double) return Double; pragma Import (C, Sin, "sinl"); + pragma Pure_Function (Sin); function Cos (X : Double) return Double; pragma Import (C, Cos, "cosl"); + pragma Pure_Function (Cos); function Tan (X : Double) return Double; pragma Import (C, Tan, "tanl"); + pragma Pure_Function (Tan); function Exp (X : Double) return Double; pragma Import (C, Exp, "expl"); + pragma Pure_Function (Exp); function Sqrt (X : Double) return Double; pragma Import (C, Sqrt, "sqrtl"); + pragma Pure_Function (Sqrt); function Log (X : Double) return Double; pragma Import (C, Log, "logl"); + pragma Pure_Function (Log); function Acos (X : Double) return Double; pragma Import (C, Acos, "acosl"); + pragma Pure_Function (Acos); function Asin (X : Double) return Double; pragma Import (C, Asin, "asinl"); + pragma Pure_Function (Asin); function Atan (X : Double) return Double; pragma Import (C, Atan, "atanl"); + pragma Pure_Function (Atan); function Sinh (X : Double) return Double; pragma Import (C, Sinh, "sinhl"); + pragma Pure_Function (Sinh); function Cosh (X : Double) return Double; pragma Import (C, Cosh, "coshl"); + pragma Pure_Function (Cosh); function Tanh (X : Double) return Double; pragma Import (C, Tanh, "tanhl"); + pragma Pure_Function (Tanh); function Pow (X, Y : Double) return Double; pragma Import (C, Pow, "powl"); + pragma Pure_Function (Pow); end Ada.Numerics.Aux; diff --git a/gcc/ada/4znumaux.ads b/gcc/ada/4znumaux.ads index 9638fb0..3a995a1 100644 --- a/gcc/ada/4znumaux.ads +++ b/gcc/ada/4znumaux.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (C Library Version, VxWorks) -- -- -- --- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2003 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- -- @@ -50,48 +50,61 @@ pragma Pure (Aux); -- no libm.a library for VxWorks. type Double is digits 15; - pragma Float_Representation (IEEE_Float, Double); - -- Type Double is the type used to call the C routines. Note that this - -- is IEEE format even when running on VMS with Vax_Float representation - -- since we use the IEEE version of the C library with VMS. + -- Type Double is the type used to call the C routines + + -- We import these functions directly from C. Note that we label them + -- all as pure functions, because indeed all of them are in fact pure! function Sin (X : Double) return Double; pragma Import (C, Sin, "sin"); + pragma Pure_Function (Sin); function Cos (X : Double) return Double; pragma Import (C, Cos, "cos"); + pragma Pure_Function (Cos); function Tan (X : Double) return Double; pragma Import (C, Tan, "tan"); + pragma Pure_Function (Tan); function Exp (X : Double) return Double; pragma Import (C, Exp, "exp"); + pragma Pure_Function (Exp); function Sqrt (X : Double) return Double; pragma Import (C, Sqrt, "sqrt"); + pragma Pure_Function (Sqrt); function Log (X : Double) return Double; pragma Import (C, Log, "log"); + pragma Pure_Function (Log); function Acos (X : Double) return Double; pragma Import (C, Acos, "acos"); + pragma Pure_Function (Acos); function Asin (X : Double) return Double; pragma Import (C, Asin, "asin"); + pragma Pure_Function (Asin); function Atan (X : Double) return Double; pragma Import (C, Atan, "atan"); + pragma Pure_Function (Atan); function Sinh (X : Double) return Double; pragma Import (C, Sinh, "sinh"); + pragma Pure_Function (Sinh); function Cosh (X : Double) return Double; pragma Import (C, Cosh, "cosh"); + pragma Pure_Function (Cosh); function Tanh (X : Double) return Double; pragma Import (C, Tanh, "tanh"); + pragma Pure_Function (Tanh); function Pow (X, Y : Double) return Double; pragma Import (C, Pow, "pow"); + pragma Pure_Function (Pow); end Ada.Numerics.Aux; diff --git a/gcc/ada/4zsytaco.adb b/gcc/ada/4zsytaco.adb index f8ed434..fcb320a 100644 --- a/gcc/ada/4zsytaco.adb +++ b/gcc/ada/4zsytaco.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- -- @@ -52,8 +52,9 @@ package body Ada.Synchronous_Task_Control is St := semTake (S.Sema, NO_WAIT); + -- If we took the semaphore, reset semaphore state to FULL + if St = OK then - -- Took the semaphore. Reset semaphore state to FULL Result := True; St := semGive (S.Sema); end if; @@ -74,6 +75,7 @@ package body Ada.Synchronous_Task_Control is -- empty (St = OK) or have left it empty. St := semTake (S.Sema, NO_WAIT); + pragma Assert (St = OK); end Set_False; -------------- @@ -82,7 +84,7 @@ package body Ada.Synchronous_Task_Control is procedure Set_True (S : in out Suspension_Object) is St : STATUS; - + pragma Unreferenced (St); begin St := semGive (S.Sema); end Set_True; @@ -136,7 +138,7 @@ package body Ada.Synchronous_Task_Control is procedure Finalize (S : in out Suspension_Object) is St : STATUS; - + pragma Unreferenced (St); begin St := semDelete (S.Sema); St := semDelete (S.Mutex); diff --git a/gcc/ada/56taprop.adb b/gcc/ada/56taprop.adb index 60e87f0..ffaf40a 100644 --- a/gcc/ada/56taprop.adb +++ b/gcc/ada/56taprop.adb @@ -332,7 +332,6 @@ package body System.Task_Primitives.Operations is procedure Finalize_Lock (L : access Lock) is Result : Interfaces.C.int; - begin Result := pthread_mutex_destroy (L.Mutex'Access); pragma Assert (Result = 0); @@ -340,7 +339,6 @@ package body System.Task_Primitives.Operations is procedure Finalize_Lock (L : access RTS_Lock) is Result : Interfaces.C.int; - begin Result := pthread_mutex_destroy (L); pragma Assert (Result = 0); @@ -382,7 +380,6 @@ package body System.Task_Primitives.Operations is (L : access RTS_Lock; Global_Lock : Boolean := False) is Result : Interfaces.C.int; - begin if not Single_Lock or else Global_Lock then Result := pthread_mutex_lock (L); @@ -429,7 +426,6 @@ package body System.Task_Primitives.Operations is procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is Result : Interfaces.C.int; - begin if not Single_Lock or else Global_Lock then Result := pthread_mutex_unlock (L); @@ -439,7 +435,6 @@ package body System.Task_Primitives.Operations is procedure Unlock (T : Task_ID) is Result : Interfaces.C.int; - begin if not Single_Lock then Result := pthread_mutex_unlock (T.Common.LL.L'Access); @@ -456,7 +451,6 @@ package body System.Task_Primitives.Operations is Reason : System.Tasking.Task_States) is pragma Unreferenced (Reason); - Result : Interfaces.C.int; begin @@ -468,7 +462,7 @@ package body System.Task_Primitives.Operations is (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); end if; - -- EINTR is not considered a failure. + -- EINTR is not considered a failure pragma Assert (Result = 0 or else Result = EINTR); end Sleep; @@ -654,7 +648,6 @@ package body System.Task_Primitives.Operations is function Monotonic_Clock return Duration is TS : aliased timespec; Result : Interfaces.C.int; - begin Result := clock_gettime (clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access); @@ -669,7 +662,6 @@ package body System.Task_Primitives.Operations is function RT_Resolution return Duration is Res : aliased timespec; Result : Interfaces.C.int; - begin Result := clock_getres (clock_id => CLOCK_REALTIME, Res => Res'Unchecked_Access); @@ -683,9 +675,7 @@ package body System.Task_Primitives.Operations is procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is pragma Unreferenced (Reason); - Result : Interfaces.C.int; - begin Result := pthread_cond_signal (T.Common.LL.CV'Access); pragma Assert (Result = 0); @@ -697,7 +687,7 @@ package body System.Task_Primitives.Operations is procedure Yield (Do_Yield : Boolean := True) is Result : Interfaces.C.int; - + pragma Unreferenced (Result); begin if Do_Yield then Result := sched_yield; @@ -923,6 +913,7 @@ package body System.Task_Primitives.Operations is end if; if Stack_Base_Available then + -- If Stack Checking is supported then allocate 2 additional pages: -- -- In the worst case, stack is allocated at something like @@ -1028,7 +1019,6 @@ package body System.Task_Primitives.Operations is procedure Abort_Task (T : Task_ID) is Result : Interfaces.C.int; - begin Result := pthread_kill (T.Common.LL.Thread, Signal (System.Interrupt_Management.Abort_Task_Interrupt)); @@ -1095,7 +1085,6 @@ package body System.Task_Primitives.Operations is is pragma Unreferenced (T); pragma Unreferenced (Thread_Self); - begin return False; end Suspend_Task; @@ -1106,12 +1095,10 @@ package body System.Task_Primitives.Operations is function Resume_Task (T : ST.Task_ID; - Thread_Self : Thread_Id) - return Boolean + Thread_Self : Thread_Id) return Boolean is pragma Unreferenced (T); pragma Unreferenced (Thread_Self); - begin return False; end Resume_Task; diff --git a/gcc/ada/56tpopsp.adb b/gcc/ada/56tpopsp.adb index ece470e..ade612c 100644 --- a/gcc/ada/56tpopsp.adb +++ b/gcc/ada/56tpopsp.adb @@ -92,11 +92,14 @@ package body Specific is -- tasks. function Self return Task_ID is - Result : Interfaces.C.int; Value : aliased System.Address; + Result : Interfaces.C.int; + pragma Unreferenced (Result); + begin Result := st_getspecific (ATCB_Key, Value'Address); + -- Is it OK not to check this result??? -- If the key value is Null, then it is a non-Ada task. diff --git a/gcc/ada/5amastop.adb b/gcc/ada/5amastop.adb index 723e4a3..956efa4 100644 --- a/gcc/ada/5amastop.adb +++ b/gcc/ada/5amastop.adb @@ -7,7 +7,7 @@ -- B o d y -- -- (Version for Alpha/Dec Unix) -- -- -- --- Copyright (C) 1999-2002 Ada Core Technologies, Inc. -- +-- Copyright (C) 1999-2003 Ada Core Technologies, 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- -- @@ -105,7 +105,8 @@ package body System.Machine_State_Operations is -- asm instruction takes 4 bytes. So we must remove this value from -- c_get_code_loc to have the call point. - Loc : Code_Loc := c_get_code_loc (M); + Loc : constant Code_Loc := c_get_code_loc (M); + begin if Loc = 0 then return 0; diff --git a/gcc/ada/5aml-tgt.adb b/gcc/ada/5aml-tgt.adb index 69385b6..85bd715 100644 --- a/gcc/ada/5aml-tgt.adb +++ b/gcc/ada/5aml-tgt.adb @@ -189,7 +189,9 @@ package body MLib.Tgt is Success : Boolean; Oldpath : String (1 .. Lib_Version'Length + 1); Newpath : String (1 .. Lib_File'Length + 1); - Result : Integer; + + Result : Integer; + pragma Unreferenced (Result); function Symlink (Oldpath : System.Address; diff --git a/gcc/ada/5ataprop.adb b/gcc/ada/5ataprop.adb index 259790b..d67490f 100644 --- a/gcc/ada/5ataprop.adb +++ b/gcc/ada/5ataprop.adb @@ -626,9 +626,7 @@ package body System.Task_Primitives.Operations is procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is pragma Unreferenced (Reason); - Result : Interfaces.C.int; - begin Result := pthread_cond_signal (T.Common.LL.CV'Access); pragma Assert (Result = 0); @@ -640,6 +638,7 @@ package body System.Task_Primitives.Operations is procedure Yield (Do_Yield : Boolean := True) is Result : Interfaces.C.int; + pragma Unreferenced (Result); begin if Do_Yield then Result := sched_yield; @@ -972,7 +971,6 @@ package body System.Task_Primitives.Operations is procedure Abort_Task (T : Task_ID) is Result : Interfaces.C.int; - begin Result := pthread_kill @@ -1038,8 +1036,7 @@ package body System.Task_Primitives.Operations is function Suspend_Task (T : ST.Task_ID; - Thread_Self : Thread_Id) - return Boolean + Thread_Self : Thread_Id) return Boolean is pragma Warnings (Off, T); pragma Warnings (Off, Thread_Self); @@ -1054,8 +1051,7 @@ package body System.Task_Primitives.Operations is function Resume_Task (T : ST.Task_ID; - Thread_Self : Thread_Id) - return Boolean + Thread_Self : Thread_Id) return Boolean is pragma Warnings (Off, T); pragma Warnings (Off, Thread_Self); @@ -1074,12 +1070,11 @@ package body System.Task_Primitives.Operations is Tmp_Set : aliased sigset_t; Result : Interfaces.C.int; - function State (Int : System.Interrupt_Management.Interrupt_ID) - return Character; + function State + (Int : System.Interrupt_Management.Interrupt_ID) return Character; pragma Import (C, State, "__gnat_get_interrupt_state"); - -- Get interrupt state. Defined in a-init.c - -- The input argument is the interrupt number, - -- and the result is one of the following: + -- Get interrupt state. Defined in a-init.c. The input argument is + -- the interrupt number, and the result is one of the following: Default : constant Character := 's'; -- 'n' this interrupt not set by any Interrupt_State pragma diff --git a/gcc/ada/5atpopsp.adb b/gcc/ada/5atpopsp.adb index dc4c013..68b54c8 100644 --- a/gcc/ada/5atpopsp.adb +++ b/gcc/ada/5atpopsp.adb @@ -68,7 +68,6 @@ package body Specific is procedure Set (Self_Id : Task_ID) is Result : Interfaces.C.int; - begin Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id)); pragma Assert (Result = 0); diff --git a/gcc/ada/5ftaprop.adb b/gcc/ada/5ftaprop.adb index af9ecb5..acedd71 100644 --- a/gcc/ada/5ftaprop.adb +++ b/gcc/ada/5ftaprop.adb @@ -31,7 +31,7 @@ -- -- ------------------------------------------------------------------------------ --- This is a IRIX (pthread library) version of this package. +-- This is a IRIX (pthread library) version of this package -- This package contains all the GNULL primitives that interface directly -- with the underlying OS. @@ -222,7 +222,6 @@ package body System.Task_Primitives.Operations is procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is pragma Unreferenced (On); pragma Unreferenced (T); - begin null; end Stack_Guard; @@ -332,7 +331,6 @@ package body System.Task_Primitives.Operations is procedure Finalize_Lock (L : access Lock) is Result : Interfaces.C.int; - begin Result := pthread_mutex_destroy (L); pragma Assert (Result = 0); @@ -340,7 +338,6 @@ package body System.Task_Primitives.Operations is procedure Finalize_Lock (L : access RTS_Lock) is Result : Interfaces.C.int; - begin Result := pthread_mutex_destroy (L); pragma Assert (Result = 0); @@ -356,13 +353,14 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_lock (L); Ceiling_Violation := Result = EINVAL; - -- assumes the cause of EINVAL is a priority ceiling violation + -- Assumes the cause of EINVAL is a priority ceiling violation pragma Assert (Result = 0 or else Result = EINVAL); end Write_Lock; procedure Write_Lock - (L : access RTS_Lock; Global_Lock : Boolean := False) + (L : access RTS_Lock; + Global_Lock : Boolean := False) is Result : Interfaces.C.int; begin @@ -396,7 +394,6 @@ package body System.Task_Primitives.Operations is procedure Unlock (L : access Lock) is Result : Interfaces.C.int; - begin Result := pthread_mutex_unlock (L); pragma Assert (Result = 0); @@ -584,7 +581,6 @@ package body System.Task_Primitives.Operations is function Monotonic_Clock return Duration is TS : aliased timespec; Result : Interfaces.C.int; - begin Result := clock_gettime (Real_Time_Clock_Id, TS'Unchecked_Access); pragma Assert (Result = 0); @@ -614,9 +610,7 @@ package body System.Task_Primitives.Operations is procedure Wakeup (T : ST.Task_ID; Reason : System.Tasking.Task_States) is pragma Unreferenced (Reason); - Result : Interfaces.C.int; - begin Result := pthread_cond_signal (T.Common.LL.CV'Access); pragma Assert (Result = 0); @@ -628,7 +622,7 @@ package body System.Task_Primitives.Operations is procedure Yield (Do_Yield : Boolean := True) is Result : Interfaces.C.int; - + pragma Unreferenced (Result); begin if Do_Yield then Result := sched_yield; @@ -1069,9 +1063,8 @@ package body System.Task_Primitives.Operations is function State (Int : System.Interrupt_Management.Interrupt_ID) return Character; pragma Import (C, State, "__gnat_get_interrupt_state"); - -- Get interrupt state. Defined in a-init.c - -- The input argument is the interrupt number, - -- and the result is one of the following: + -- Get interrupt state. Defined in a-init.c. The input argument is + -- the interrupt number, and the result is one of the following: Default : constant Character := 's'; -- 'n' this interrupt not set by any Interrupt_State pragma diff --git a/gcc/ada/5ginterr.adb b/gcc/ada/5ginterr.adb index b2a861a..fd3f9c0 100644 --- a/gcc/ada/5ginterr.adb +++ b/gcc/ada/5ginterr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2002 Free Software Fundation -- +-- Copyright (C) 1998-2003 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- -- @@ -244,11 +244,9 @@ package body System.Interrupts is ------------------------------------- function Has_Interrupt_Or_Attach_Handler - (Object : access Dynamic_Interrupt_Protection) - return Boolean + (Object : access Dynamic_Interrupt_Protection) return Boolean is pragma Unreferenced (Object); - begin return True; end Has_Interrupt_Or_Attach_Handler; @@ -279,11 +277,9 @@ package body System.Interrupts is ------------------------------------- function Has_Interrupt_Or_Attach_Handler - (Object : access Static_Interrupt_Protection) - return Boolean + (Object : access Static_Interrupt_Protection) return Boolean is pragma Unreferenced (Object); - begin return True; end Has_Interrupt_Or_Attach_Handler; @@ -320,8 +316,9 @@ package body System.Interrupts is -- Current_Handler -- --------------------- - function Current_Handler (Interrupt : Interrupt_ID) - return Parameterless_Handler is + function Current_Handler + (Interrupt : Interrupt_ID) return Parameterless_Handler + is begin if Is_Reserved (Interrupt) then raise Program_Error; @@ -466,13 +463,15 @@ package body System.Interrupts is --------------- function Reference (Interrupt : Interrupt_ID) return System.Address is - Signal : System.Address := - System.Storage_Elements.To_Address - (System.Storage_Elements.Integer_Address (Interrupt)); + Signal : constant System.Address := + System.Storage_Elements.To_Address + (System.Storage_Elements.Integer_Address (Interrupt)); begin if Is_Reserved (Interrupt) then - -- Only usable Interrupts can be used for binding it to an Entry. + + -- Only usable Interrupts can be used for binding it to an Entry + raise Program_Error; end if; diff --git a/gcc/ada/5gmastop.adb b/gcc/ada/5gmastop.adb index 7f6785c..d05a779 100644 --- a/gcc/ada/5gmastop.adb +++ b/gcc/ada/5gmastop.adb @@ -108,18 +108,20 @@ package body System.Machine_State_Operations is -- ABI-Dependent Declarations -- -------------------------------- - o32 : constant Natural := Boolean'Pos (System.Word_Size = 32); - n32 : constant Natural := Boolean'Pos (System.Word_Size = 64); + o32 : constant Boolean := System.Word_Size = 32; + n32 : constant Boolean := System.Word_Size = 64; + o32n : constant Natural := Boolean'Pos (o32); + n32n : constant Natural := Boolean'Pos (n32); -- Flags to indicate which ABI is in effect for this compilation. For the -- purposes of this unit, the n32 and n64 ABI's are identical. - LSC : constant Character := Character'Val (o32 * Character'Pos ('w') + - n32 * Character'Pos ('d')); + LSC : constant Character := Character'Val (o32n * Character'Pos ('w') + + n32n * Character'Pos ('d')); -- This is 'w' for o32, and 'd' for n32/n64, used for constructing the -- load/store instructions used to save/restore machine instructions. - Roff : constant Character := Character'Val (o32 * Character'Pos ('4') + - n32 * Character'Pos (' ')); + Roff : constant Character := Character'Val (o32n * Character'Pos ('4') + + n32n * Character'Pos (' ')); -- Offset from first byte of a __uint64 register save location where -- the register value is stored. For n32/64 we store the entire 64 -- bit register into the uint64. For o32, only 32 bits are stored @@ -156,7 +158,7 @@ package body System.Machine_State_Operations is function To_I_Type_Ptr is new Unchecked_Conversion (Address_Int, I_Type_Ptr); - Ret_Ins : I_Type_Ptr := To_I_Type_Ptr (Address_Int (Scp.SC_PC)); + Ret_Ins : constant I_Type_Ptr := To_I_Type_Ptr (Address_Int (Scp.SC_PC)); GP_Ptr : Uns32_Ptr; begin @@ -311,12 +313,11 @@ package body System.Machine_State_Operations is Scp.SC_PC := 0; else - -- Set the GP to restore to the caller value (not callee value) -- This is done only in o32 mode. In n32/n64 mode, GP is a normal -- callee save register - if o32 = 1 then + if o32 then Update_GP (Scp); end if; diff --git a/gcc/ada/5gml-tgt.adb b/gcc/ada/5gml-tgt.adb index c5390a6..cc13d37 100644 --- a/gcc/ada/5gml-tgt.adb +++ b/gcc/ada/5gml-tgt.adb @@ -172,7 +172,9 @@ package body MLib.Tgt is Success : Boolean; Oldpath : String (1 .. Lib_Version'Length + 1); Newpath : String (1 .. Lib_File'Length + 1); - Result : Integer; + + Result : Integer; + pragma Unreferenced (Result); function Symlink (Oldpath : System.Address; diff --git a/gcc/ada/5gtaprop.adb b/gcc/ada/5gtaprop.adb index b9b88c3..c9041ba 100644 --- a/gcc/ada/5gtaprop.adb +++ b/gcc/ada/5gtaprop.adb @@ -534,7 +534,6 @@ package body System.Task_Primitives.Operations is Reason : System.Tasking.Task_States) is Result : Interfaces.C.int; - begin Result := pthread_cond_signal (T.Common.LL.CV'Access); pragma Assert (Result = 0); @@ -878,8 +877,7 @@ package body System.Task_Primitives.Operations is function Suspend_Task (T : ST.Task_ID; - Thread_Self : Thread_Id) - return Boolean + Thread_Self : Thread_Id) return Boolean is begin if T.Common.LL.Thread /= Thread_Self then @@ -895,8 +893,7 @@ package body System.Task_Primitives.Operations is function Resume_Task (T : ST.Task_ID; - Thread_Self : Thread_Id) - return Boolean + Thread_Self : Thread_Id) return Boolean is begin if T.Common.LL.Thread /= Thread_Self then diff --git a/gcc/ada/5hml-tgt.adb b/gcc/ada/5hml-tgt.adb index c790df8..a8cbc79 100644 --- a/gcc/ada/5hml-tgt.adb +++ b/gcc/ada/5hml-tgt.adb @@ -125,7 +125,8 @@ package body MLib.Tgt is Init_Fini : Argument_List_Access := Empty_Argument_List; - Common_Options : Argument_List := Options & new String'(PIC_Option); + Common_Options : constant Argument_List := + Options & new String'(PIC_Option); -- Common set of options to the gcc command performing the link. -- On HPUX, this command eventually resorts to collect2, which may -- generate a C file and compile it on the fly. This compilation shall @@ -177,12 +178,13 @@ package body MLib.Tgt is Success : Boolean; Oldpath : String (1 .. Lib_Version'Length + 1); Newpath : String (1 .. Lib_File'Length + 1); - Result : Integer; + + Result : Integer; + pragma Unreferenced (Result); function Symlink (Oldpath : System.Address; - Newpath : System.Address) - return Integer; + Newpath : System.Address) return Integer; pragma Import (C, Symlink, "__gnat_symlink"); begin diff --git a/gcc/ada/5htaprop.adb b/gcc/ada/5htaprop.adb index 434806c..d917dda 100644 --- a/gcc/ada/5htaprop.adb +++ b/gcc/ada/5htaprop.adb @@ -600,7 +600,7 @@ package body System.Task_Primitives.Operations is procedure Yield (Do_Yield : Boolean := True) is Result : Interfaces.C.int; - + pragma Unreferenced (Result); begin if Do_Yield then Result := sched_yield; diff --git a/gcc/ada/5htraceb.adb b/gcc/ada/5htraceb.adb index 67cb6d3..dce251a 100644 --- a/gcc/ada/5htraceb.adb +++ b/gcc/ada/5htraceb.adb @@ -221,8 +221,7 @@ package body System.Traceback is (Pc : Address; Space : Address; Table_Start : Address; - Table_End : Address) - return Address; + Table_End : Address) return Address; pragma Import (C, U_get_unwind_entry, "U_get_unwind_entry"); -- Given the bounds of an unwind table, return the address of the -- unwind descriptor associated with a code location/space. In the case @@ -254,8 +253,7 @@ package body System.Traceback is function U_get_previous_frame_x (current_frame : access CFD; previous_frame : access PFD; - previous_size : Integer) - return Integer; + previous_size : Integer) return Integer; pragma Import (C, U_get_previous_frame_x, "U_get_previous_frame_x"); -- Fetch the data describing the "previous" frame relatively to the -- "current" one. "previous_size" should be the size of the "previous" @@ -270,9 +268,8 @@ package body System.Traceback is ------------------ function C_Call_Chain - (Traceback : System.Address; - Max_Len : Natural) - return Natural + (Traceback : System.Address; + Max_Len : Natural) return Natural is Val : Natural; @@ -530,10 +527,12 @@ package body System.Traceback is and then U_is_shared_pc (Frame.cur_rlo, Frame.cur_r19) /= 0 then declare - Shlib_UWT : UWT := U_get_shLib_unwind_table (Frame.cur_r19); - Shlib_Start : Address := U_get_shLib_text_addr (Frame.cur_r19); - Rlo_Offset : Address := Frame.cur_rlo - Shlib_Start; - + Shlib_UWT : constant UWT := + U_get_shLib_unwind_table (Frame.cur_r19); + Shlib_Start : constant Address := + U_get_shLib_text_addr (Frame.cur_r19); + Rlo_Offset : constant Address := + Frame.cur_rlo - Shlib_Start; begin UWD_Address := U_get_unwind_entry (Rlo_Offset, Frame.cur_rls, diff --git a/gcc/ada/5itaprop.adb b/gcc/ada/5itaprop.adb index 2f08640..9fae2de 100644 --- a/gcc/ada/5itaprop.adb +++ b/gcc/ada/5itaprop.adb @@ -656,9 +656,7 @@ package body System.Task_Primitives.Operations is procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is pragma Unreferenced (Reason); - Result : Interfaces.C.int; - begin Result := pthread_cond_signal (T.Common.LL.CV'Access); pragma Assert (Result = 0); @@ -671,7 +669,6 @@ package body System.Task_Primitives.Operations is procedure Yield (Do_Yield : Boolean := True) is Result : Interfaces.C.int; pragma Unreferenced (Result); - begin if Do_Yield then Result := sched_yield; @@ -988,8 +985,7 @@ package body System.Task_Primitives.Operations is function Suspend_Task (T : ST.Task_ID; - Thread_Self : Thread_Id) - return Boolean + Thread_Self : Thread_Id) return Boolean is begin if T.Common.LL.Thread /= Thread_Self then @@ -1005,8 +1001,7 @@ package body System.Task_Primitives.Operations is function Resume_Task (T : ST.Task_ID; - Thread_Self : Thread_Id) - return Boolean + Thread_Self : Thread_Id) return Boolean is begin if T.Common.LL.Thread /= Thread_Self then diff --git a/gcc/ada/5lml-tgt.adb b/gcc/ada/5lml-tgt.adb index b9d4217..fbe5054 100644 --- a/gcc/ada/5lml-tgt.adb +++ b/gcc/ada/5lml-tgt.adb @@ -175,12 +175,13 @@ package body MLib.Tgt is Success : Boolean; Oldpath : String (1 .. Lib_Version'Length + 1); Newpath : String (1 .. Lib_File'Length + 1); - Result : Integer; + + Result : Integer; + pragma Unreferenced (Result); function Symlink (Oldpath : System.Address; - Newpath : System.Address) - return Integer; + Newpath : System.Address) return Integer; pragma Import (C, Symlink, "__gnat_symlink"); begin diff --git a/gcc/ada/5sml-tgt.adb b/gcc/ada/5sml-tgt.adb index a7bc933..f4facc9 100644 --- a/gcc/ada/5sml-tgt.adb +++ b/gcc/ada/5sml-tgt.adb @@ -171,7 +171,9 @@ package body MLib.Tgt is Success : Boolean; Oldpath : String (1 .. Lib_Version'Length + 1); Newpath : String (1 .. Lib_File'Length + 1); - Result : Integer; + + Result : Integer; + pragma Unreferenced (Result); function Symlink (Oldpath : System.Address; diff --git a/gcc/ada/5staprop.adb b/gcc/ada/5staprop.adb index 588c0d3..e555f1f 100644 --- a/gcc/ada/5staprop.adb +++ b/gcc/ada/5staprop.adb @@ -275,14 +275,11 @@ package body System.Task_Primitives.Operations is ------------ Check_Count : Integer := 0; - Old_Owner : Task_ID; Lock_Count : Integer := 0; Unlock_Count : Integer := 0; function To_Lock_Ptr is new Unchecked_Conversion (RTS_Lock_Ptr, Lock_Ptr); - function To_Task_ID is - new Unchecked_Conversion (Owner_ID, Task_ID); function To_Owner_ID is new Unchecked_Conversion (Task_ID, Owner_ID); @@ -300,9 +297,11 @@ package body System.Task_Primitives.Operations is pragma Unreferenced (Context); Self_ID : Task_ID := Self; - Result : Interfaces.C.int; Old_Set : aliased sigset_t; + Result : Interfaces.C.int; + pragma Unreferenced (Result); + begin -- It is not safe to raise an exception when using ZCX and the GCC -- exception handling mechanism. @@ -758,7 +757,9 @@ package body System.Task_Primitives.Operations is is pragma Unreferenced (Loss_Of_Inheritance); - Result : Interfaces.C.int; + Result : Interfaces.C.int; + pragma Unreferenced (Result); + Param : aliased struct_pcparms; use Task_Info; @@ -1605,7 +1606,6 @@ package body System.Task_Primitives.Operations is if Unlock_Count - Check_Count > 1000 then Check_Count := Unlock_Count; - Old_Owner := To_Task_ID (Single_RTS_Lock.Owner); end if; -- Check that caller is abort-deferred diff --git a/gcc/ada/5stpopsp.adb b/gcc/ada/5stpopsp.adb index 8ff5797..eb32dd2 100644 --- a/gcc/ada/5stpopsp.adb +++ b/gcc/ada/5stpopsp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2002, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2003, Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -31,7 +31,7 @@ -- -- ------------------------------------------------------------------------------ --- This is a version for Solaris native threads. +-- This is a version for Solaris native threads separate (System.Task_Primitives.Operations) package body Specific is @@ -54,11 +54,9 @@ package body Specific is function Is_Valid_Task return Boolean is Unknown_Task : aliased System.Address; Result : Interfaces.C.int; - begin Result := thr_getspecific (ATCB_Key, Unknown_Task'Unchecked_Access); pragma Assert (Result = 0); - return Unknown_Task /= System.Null_Address; end Is_Valid_Task; diff --git a/gcc/ada/5vasthan.adb b/gcc/ada/5vasthan.adb index 5f6c67e..86d0402 100644 --- a/gcc/ada/5vasthan.adb +++ b/gcc/ada/5vasthan.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2004 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -320,6 +320,7 @@ package body System.AST_Handling is procedure Allocate_New_AST_Server is Dummy : AST_Server_Task_Ptr; + pragma Unreferenced (Dummy); begin if Num_AST_Servers = Max_AST_Servers then @@ -454,8 +455,7 @@ package body System.AST_Handling is function Create_AST_Handler (Taskid : ATID.Task_Id; - Entryno : Natural) - return System.Aux_DEC.AST_Handler + Entryno : Natural) return System.Aux_DEC.AST_Handler is Attr_Ref : Attribute_Handle; @@ -465,7 +465,7 @@ package body System.AST_Handling is function To_Descriptor_Ref is new Ada.Unchecked_Conversion (AST_Handler, Descriptor_Ref); - Original_Descriptor_Ref : Descriptor_Ref := + Original_Descriptor_Ref : constant Descriptor_Ref := To_Descriptor_Ref (Process_AST_Ptr); begin diff --git a/gcc/ada/5vinmaop.adb b/gcc/ada/5vinmaop.adb index 02e1911..3d770f2 100644 --- a/gcc/ada/5vinmaop.adb +++ b/gcc/ada/5vinmaop.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -119,7 +119,7 @@ package body System.Interrupt_Management.Operations is function Interrupt_Wait (Mask : access Interrupt_Mask) return Interrupt_ID is - Self_ID : Task_ID := Self; + Self_ID : constant Task_ID := Self; Iosb : IO_Status_Block_Type := (0, 0, 0); Status : Cond_Value_Type; diff --git a/gcc/ada/5vinterr.adb b/gcc/ada/5vinterr.adb index 2f78912..f41f654 100644 --- a/gcc/ada/5vinterr.adb +++ b/gcc/ada/5vinterr.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. -- -- -- -- 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- -- @@ -219,17 +219,18 @@ package body System.Interrupts is pragma Volatile_Components (User_Entry); -- Holds the task and entry index (if any) for each interrupt - Blocked : array (Interrupt_ID'Range) of Boolean := (others => False); - pragma Volatile_Components (Blocked); + Blocked : constant array (Interrupt_ID'Range) of Boolean := + (others => False); +-- ??? pragma Volatile_Components (Blocked); -- True iff the corresponding interrupt is blocked in the process level Ignored : array (Interrupt_ID'Range) of Boolean := (others => False); pragma Volatile_Components (Ignored); -- True iff the corresponding interrupt is blocked in the process level - Last_Unblocker : - array (Interrupt_ID'Range) of Task_ID := (others => Null_Task); - pragma Volatile_Components (Last_Unblocker); + Last_Unblocker : constant array (Interrupt_ID'Range) of Task_ID := + (others => Null_Task); +-- ??? pragma Volatile_Components (Last_Unblocker); -- Holds the ID of the last Task which Unblocked this Interrupt. -- It contains Null_Task if no tasks have ever requested the -- Unblocking operation or the Interrupt is currently Blocked. @@ -324,7 +325,7 @@ package body System.Interrupts is Ptr := Registered_Handler_Head; - while (Ptr /= null) loop + while Ptr /= null loop if Ptr.H = Fat.Handler_Addr then return True; end if; @@ -726,8 +727,6 @@ package body System.Interrupts is (Interrupt : Interrupt_ID; Static : Boolean) is - Old_Handler : Parameterless_Handler; - begin if User_Entry (Interrupt).T /= Null_Task then -- In case we have an Interrupt Entry installed. @@ -754,8 +753,6 @@ package body System.Interrupts is Ignored (Interrupt) := False; - Old_Handler := User_Handler (Interrupt).H; - -- The new handler User_Handler (Interrupt).H := null; @@ -959,7 +956,6 @@ package body System.Interrupts is Tmp_ID : Task_ID; Tmp_Entry_Index : Task_Entry_Index; Intwait_Mask : aliased IMNG.Interrupt_Mask; - Ret_Interrupt : IMNG.Interrupt_ID; begin -- By making this task independent of master, when the process @@ -1016,7 +1012,6 @@ package body System.Interrupts is else Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag; - Ret_Interrupt := IMOP.Interrupt_Wait (Intwait_Mask'Access); Self_ID.Common.State := Runnable; if not (Self_ID.Deferral_Level = 0 diff --git a/gcc/ada/5vml-tgt.adb b/gcc/ada/5vml-tgt.adb index 269e8b0..ecc3911 100644 --- a/gcc/ada/5vml-tgt.adb +++ b/gcc/ada/5vml-tgt.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003, Ada Core Technologies, Inc. -- +-- Copyright (C) 2003-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- -- @@ -25,10 +25,7 @@ -- -- ------------------------------------------------------------------------------ --- This package provides a set of target dependent routines to build --- static, dynamic and shared libraries. - --- This is the VMS version of the body. +-- This is the VMS version of the body with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Text_IO; use Ada.Text_IO; @@ -142,8 +139,6 @@ package body MLib.Tgt is pragma Unreferenced (Lib_Address); pragma Unreferenced (Relocatable); - - Lib_File : constant String := Lib_Dir & Directory_Separator & "lib" & Fil.Ext_To (Lib_Filename, DLL_Ext); @@ -152,7 +147,8 @@ package body MLib.Tgt is Last_Opt : Natural := Opts'Last; Opts2 : Argument_List (Options'Range); Last_Opt2 : Natural := Opts2'First - 1; - Inter : Argument_List := Interfaces; + + Inter : constant Argument_List := Interfaces; function Is_Interface (Obj_File : String) return Boolean; -- For a Stand-Alone Library, returns True if Obj_File is the object @@ -172,9 +168,10 @@ package body MLib.Tgt is function Is_Interface (Obj_File : String) return Boolean is ALI : constant String := - Fil.Ext_To - (Filename => To_Lower (Base_Name (Obj_File)), - New_Ext => "ali"); + Fil.Ext_To + (Filename => To_Lower (Base_Name (Obj_File)), + New_Ext => "ali"); + begin if Inter'Length = 0 then return True; @@ -203,7 +200,6 @@ package body MLib.Tgt is begin if Symbol_Data.Symbol_File = No_Name then return "symvec.opt"; - else return Get_Name_String (Symbol_Data.Symbol_File); end if; @@ -239,9 +235,11 @@ package body MLib.Tgt is end Version_String; Opt_File_Name : constant String := Option_File_Name; + Version : constant String := Version_String; For_Linker_Opt : constant String_Access := new String'("--for-linker=" & Opt_File_Name); - Version : constant String := Version_String; + + -- Start of processing for Build_Dynamic_Library begin VMS_Options (VMS_Options'First + 1) := For_Linker_Opt; @@ -423,6 +421,7 @@ package body MLib.Tgt is declare Index : Natural := Opts'First; Opt : String_Access; + begin while Index <= Last_Opt loop Opt := Opts (Index); diff --git a/gcc/ada/5vtaprop.adb b/gcc/ada/5vtaprop.adb index 8a291c2..8603f8b 100644 --- a/gcc/ada/5vtaprop.adb +++ b/gcc/ada/5vtaprop.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. -- -- -- -- 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- -- @@ -127,11 +127,11 @@ package body System.Task_Primitives.Operations is procedure Set (Self_Id : Task_ID); pragma Inline (Set); - -- Set the self id for the current task. + -- Set the self id for the current task function Self return Task_ID; pragma Inline (Self); - -- Return a pointer to the Ada Task Control Block of the calling task. + -- Return a pointer to the Ada Task Control Block of the calling task end Specific; @@ -143,7 +143,7 @@ package body System.Task_Primitives.Operations is --------------------------------- function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; - -- Allocate and Initialize a new ATCB for the current Thread. + -- Allocate and Initialize a new ATCB for the current Thread function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID is separate; @@ -160,17 +160,17 @@ package body System.Task_Primitives.Operations is -- Signal the condition variable when AST fires. procedure Timer_Sleep_AST (ID : Address) is - Result : Interfaces.C.int; - Self_ID : Task_ID := To_Task_ID (ID); - + Result : Interfaces.C.int; + Self_ID : 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); + pragma Assert (Result = 0); end Timer_Sleep_AST; - ------------------- - -- Stack_Guard -- - ------------------- + ----------------- + -- Stack_Guard -- + ----------------- -- The underlying thread system sets a guard page at the -- bottom of a thread stack, so nothing is needed. @@ -179,7 +179,6 @@ package body System.Task_Primitives.Operations is procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is pragma Unreferenced (T); pragma Unreferenced (On); - begin null; end Stack_Guard; @@ -281,7 +280,6 @@ package body System.Task_Primitives.Operations is procedure Finalize_Lock (L : access Lock) is Result : Interfaces.C.int; - begin Result := pthread_mutex_destroy (L.L'Access); pragma Assert (Result = 0); @@ -289,7 +287,6 @@ package body System.Task_Primitives.Operations is procedure Finalize_Lock (L : access RTS_Lock) is Result : Interfaces.C.int; - begin Result := pthread_mutex_destroy (L); pragma Assert (Result = 0); @@ -308,7 +305,7 @@ package body System.Task_Primitives.Operations is begin Current_Prio := Get_Priority (Self_ID); - -- If there is no other tasks, no need to check priorities. + -- If there is no other tasks, no need to check priorities if All_Tasks_Link /= Null_Task and then L.Prio < Interfaces.C.int (Current_Prio) @@ -331,7 +328,6 @@ package body System.Task_Primitives.Operations is Global_Lock : Boolean := False) is Result : Interfaces.C.int; - begin if not Single_Lock or else Global_Lock then Result := pthread_mutex_lock (L); @@ -341,7 +337,6 @@ package body System.Task_Primitives.Operations is procedure Write_Lock (T : Task_ID) is Result : Interfaces.C.int; - begin if not Single_Lock then Result := pthread_mutex_lock (T.Common.LL.L'Access); @@ -364,7 +359,6 @@ package body System.Task_Primitives.Operations is procedure Unlock (L : access Lock) is Result : Interfaces.C.int; - begin Result := pthread_mutex_unlock (L.L'Access); pragma Assert (Result = 0); @@ -372,7 +366,6 @@ package body System.Task_Primitives.Operations is procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is Result : Interfaces.C.int; - begin if not Single_Lock or else Global_Lock then Result := pthread_mutex_unlock (L); @@ -382,7 +375,6 @@ package body System.Task_Primitives.Operations is procedure Unlock (T : Task_ID) is Result : Interfaces.C.int; - begin if not Single_Lock then Result := pthread_mutex_unlock (T.Common.LL.L'Access); @@ -410,7 +402,7 @@ package body System.Task_Primitives.Operations is (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); end if; - -- EINTR is not considered a failure. + -- EINTR is not considered a failure pragma Assert (Result = 0 or else Result = EINTR); @@ -440,6 +432,8 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; Status : Cond_Value_Type; + -- The body below requires more comments ??? + begin Timedout := False; Yielded := False; @@ -465,10 +459,12 @@ package body System.Task_Primitives.Operations is if Single_Lock then Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + pragma Assert (Result = 0); else Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); end if; Yielded := True; @@ -504,6 +500,8 @@ package body System.Task_Primitives.Operations is Lock_RTS; end if; + -- More comments required in body below ??? + SSL.Abort_Defer.all; Write_Lock (Self_ID); @@ -538,9 +536,11 @@ package body System.Task_Primitives.Operations is if Single_Lock then Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + pragma Assert (Result = 0); else Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); end if; Yielded := True; @@ -560,6 +560,7 @@ package body System.Task_Primitives.Operations is if not Yielded then Result := sched_yield; + pragma Assert (Result = 0); end if; SSL.Abort_Undefer.all; @@ -601,7 +602,7 @@ package body System.Task_Primitives.Operations is procedure Yield (Do_Yield : Boolean := True) is Result : Interfaces.C.int; - + pragma Unreferenced (Result); begin if Do_Yield then Result := sched_yield; @@ -712,11 +713,13 @@ package body System.Task_Primitives.Operations is ---------------------- procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is - Mutex_Attr : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - Cond_Attr : aliased pthread_condattr_t; + Mutex_Attr : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + Cond_Attr : aliased pthread_condattr_t; begin + -- More comments required in body below ??? + if not Single_Lock then Result := pthread_mutexattr_init (Mutex_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); @@ -960,8 +963,7 @@ package body System.Task_Primitives.Operations is function Suspend_Task (T : ST.Task_ID; - Thread_Self : Thread_Id) - return Boolean + Thread_Self : Thread_Id) return Boolean is pragma Unreferenced (T); pragma Unreferenced (Thread_Self); @@ -976,12 +978,10 @@ package body System.Task_Primitives.Operations is function Resume_Task (T : ST.Task_ID; - Thread_Self : Thread_Id) - return Boolean + Thread_Self : Thread_Id) return Boolean is pragma Unreferenced (T); pragma Unreferenced (Thread_Self); - begin return False; end Resume_Task; @@ -994,7 +994,7 @@ package body System.Task_Primitives.Operations is begin Environment_Task_ID := Environment_Task; - -- Initialize the lock used to synchronize chain of all ATCBs. + -- Initialize the lock used to synchronize chain of all ATCBs Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); diff --git a/gcc/ada/5wosprim.adb b/gcc/ada/5wosprim.adb index 5ec7398..07a8ca7 100644 --- a/gcc/ada/5wosprim.adb +++ b/gcc/ada/5wosprim.adb @@ -93,28 +93,28 @@ package body System.OS_Primitives is -- Use to have indirect access to multi-word variables Tick_Frequency : aliased LARGE_INTEGER; - TFA : LIA := Tick_Frequency'Access; + TFA : constant LIA := Tick_Frequency'Access; -- Holds frequency of high-performance counter used by Clock -- Windows NT uses a 1_193_182 Hz counter on PCs. Base_Ticks : aliased LARGE_INTEGER; - BTA : LIA := Base_Ticks'Access; + BTA : constant LIA := Base_Ticks'Access; -- Holds the Tick count for the base time. Base_Monotonic_Ticks : aliased LARGE_INTEGER; - BMTA : LIA := Base_Monotonic_Ticks'Access; - -- Holds the Tick count for the base monotonic time. + BMTA : constant LIA := Base_Monotonic_Ticks'Access; + -- Holds the Tick count for the base monotonic time Base_Clock : aliased Duration; - BCA : DA := Base_Clock'Access; + BCA : constant DA := Base_Clock'Access; -- Holds the current clock for the standard clock's base time Base_Monotonic_Clock : aliased Duration; - BMCA : DA := Base_Monotonic_Clock'Access; + BMCA : constant DA := Base_Monotonic_Clock'Access; -- Holds the current clock for monotonic clock's base time Base_Time : aliased Long_Long_Integer; - BTiA : LLIA := Base_Time'Access; + BTiA : constant LLIA := Base_Time'Access; -- Holds the base time used to check for system time change, used with -- the standard clock. diff --git a/gcc/ada/5wtaprop.adb b/gcc/ada/5wtaprop.adb index aa84c28..bbbb249 100644 --- a/gcc/ada/5wtaprop.adb +++ b/gcc/ada/5wtaprop.adb @@ -1012,7 +1012,8 @@ package body System.Task_Primitives.Operations is ---------------- procedure Initialize (Environment_Task : Task_ID) is - Res : BOOL; + Discard : BOOL; + pragma Unreferenced (Discard); begin Environment_Task_ID := Environment_Task; @@ -1022,7 +1023,7 @@ package body System.Task_Primitives.Operations is -- Here we need Annex E semantics, switch the current process to the -- High_Priority_Class. - Res := + Discard := OS_Interface.SetPriorityClass (GetCurrentProcess, High_Priority_Class); diff --git a/gcc/ada/5zinit.adb b/gcc/ada/5zinit.adb index 3fe64bd..1544569 100644 --- a/gcc/ada/5zinit.adb +++ b/gcc/ada/5zinit.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003 Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2004 Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -31,18 +31,16 @@ -- -- ------------------------------------------------------------------------------ --- This is the VxWorks version of this package +-- This is the Level A cert version of this package for AE653 with Interfaces.C; --- used for int and other types +-- Used for int and other types with Ada.Exceptions; --- used for Raise_Exception +-- Used for Raise_Exception package body System.Init is - -- This unit contains initialization circuits that are system dependent. - use Ada.Exceptions; use Interfaces.C; @@ -52,6 +50,7 @@ package body System.Init is NSIG : constant := 32; -- Number of signals on the target OS + type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1); SIGILL : constant := 4; -- illegal instruction (not reset) @@ -137,9 +136,9 @@ package body System.Init is Already_Called : Boolean := False; Handler_Installed : Integer := 0; + pragma Export (C, Handler_Installed, "__gnat_handler_installed"); -- Indication of whether synchronous signal handlers have already been -- installed by a previous call to Install_Handler. - pragma Export (C, Handler_Installed, "__gnat_handler_installed"); ------------------------ -- Local procedures -- @@ -154,8 +153,10 @@ package body System.Init is ------------------------ procedure GNAT_Error_Handler (Sig : Signal) is - Mask : aliased sigset_t; + Mask : aliased sigset_t; + Result : int; + pragma Unreferenced (Result); begin -- VxWorks will always mask out the signal during the signal @@ -210,23 +211,24 @@ package body System.Init is Num_Interrupt_States : Integer; Unreserve_All_Interrupts : Integer; Exception_Tracebacks : Integer; - Zero_Cost_Exceptions : Integer) is + Zero_Cost_Exceptions : Integer) + is begin -- If this procedure has been already called once, check that the -- arguments in this call are consistent with the ones in the -- previous calls. Otherwise, raise a Program_Error exception. - -- + -- We do not check for consistency of the wide character encoding -- method. This default affects only Wide_Text_IO where no -- explicit coding method is given, and there is no particular -- reason to let this default be affected by the source -- representation of a library in any case. - -- + -- We do not check either for the consistency of exception tracebacks, -- because exception tracebacks are not normally set in Stand-Alone -- libraries. If a library or the main program set the exception -- tracebacks, then they are never reset afterwards (see below). - -- + -- The value of main_priority is meaningful only when we are -- invoked from the main program elaboration routine of an Ada -- application. Checking the consistency of this parameter should @@ -238,16 +240,16 @@ package body System.Init is -- that the case where the main program is not written in Ada is -- also properly handled, since the default value will then be -- used for this parameter. - -- + -- For identical reasons, the consistency of time_slice_val should -- not be checked. if Already_Called then - if (Gl_Locking_Policy /= Locking_Policy) or - (Gl_Queuing_Policy /= Queuing_Policy) or - (Gl_Task_Dispatching_Policy /= Task_Dispatching_Policy) or - (Gl_Unreserve_All_Interrupts /= Unreserve_All_Interrupts) or - (Gl_Exception_Tracebacks /= Exception_Tracebacks) or + if (Gl_Locking_Policy /= Locking_Policy) or else + (Gl_Queuing_Policy /= Queuing_Policy) or else + (Gl_Task_Dispatching_Policy /= Task_Dispatching_Policy) or else + (Gl_Unreserve_All_Interrupts /= Unreserve_All_Interrupts) or else + (Gl_Exception_Tracebacks /= Exception_Tracebacks) or else (Gl_Zero_Cost_Exceptions /= Zero_Cost_Exceptions) then raise Program_Error; @@ -285,7 +287,9 @@ package body System.Init is procedure Install_Handler is Mask : aliased sigset_t; Signal_Action : aliased struct_sigaction; - Result : Interfaces.C.int; + + Result : Interfaces.C.int; + pragma Unreferenced (Result); begin -- Set up signal handler to map synchronous signals to appropriate diff --git a/gcc/ada/5zinterr.adb b/gcc/ada/5zinterr.adb index 674c08f..5898e6d 100644 --- a/gcc/ada/5zinterr.adb +++ b/gcc/ada/5zinterr.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. -- -- -- -- 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- -- @@ -422,12 +422,15 @@ package body System.Interrupts is -------------------------------- -- Restore default handlers for interrupt servers. + -- This is called by the Interrupt_Manager task when it receives the abort -- signal during program finalization. procedure Finalize_Interrupt_Servers is + HW_Interrupts : constant Boolean := HW_Interrupt'Last >= 0; + begin - if HW_Interrupt'Last >= 0 then + if HW_Interrupts then for Int in HW_Interrupt loop if Server_ID (Interrupt_ID (Int)) /= null and then @@ -527,11 +530,16 @@ package body System.Interrupts is is use Interfaces.VxWorks; - Vec : constant Interrupt_Vector := - INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt)); + Vec : constant Interrupt_Vector := + INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt)); + Old_Handler : constant VOIDFUNCPTR := - intVecGet (INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt))); + intVecGet + (INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt))); + Stat : Interfaces.VxWorks.STATUS; + pragma Unreferenced (Stat); + -- ??? shouldn't we test Stat at least in a pragma Assert? begin -- Only install umbrella handler when no Ada handler has already been @@ -541,7 +549,7 @@ package body System.Interrupts is if Default_Handler (Interrupt) = null then Stat := - intConnect (Vec, VOIDFUNCPTR (Handler), System.Address (Interrupt)); + intConnect (Vec, Handler, System.Address (Interrupt)); Default_Handler (Interrupt) := Old_Handler; end if; end Install_Umbrella_Handler; @@ -611,7 +619,7 @@ package body System.Interrupts is Ptr := Registered_Handler_Head; - while (Ptr /= null) loop + while Ptr /= null loop if Ptr.H = Fat.Handler_Addr then return True; end if; @@ -653,8 +661,10 @@ package body System.Interrupts is -- server task deletes its semaphore and terminates. procedure Notify_Interrupt (Param : System.Address) is - Interrupt : Interrupt_ID := Interrupt_ID (Param); + Interrupt : constant Interrupt_ID := Interrupt_ID (Param); + Discard_Result : STATUS; + pragma Unreferenced (Discard_Result); begin Discard_Result := semGive (Semaphore_ID_Map (Interrupt)); diff --git a/gcc/ada/5zintman.adb b/gcc/ada/5zintman.adb index d5e8afc..411d86d 100644 --- a/gcc/ada/5zintman.adb +++ b/gcc/ada/5zintman.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. -- -- -- -- 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- -- @@ -86,9 +86,11 @@ package body System.Interrupt_Management is procedure Notify_Exception (signo : Signal) is Mask : aliased sigset_t; - Result : int; My_Id : t_id; + Result : int; + pragma Unreferenced (Result); + begin Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access); Result := sigdelset (Mask'Access, signo); diff --git a/gcc/ada/5zml-tgt.adb b/gcc/ada/5zml-tgt.adb index 0331c9f..c1ae724 100644 --- a/gcc/ada/5zml-tgt.adb +++ b/gcc/ada/5zml-tgt.adb @@ -67,7 +67,7 @@ package body MLib.Tgt is -- Archive_Ext -- ----------------- - function Archive_Ext return String is + function Archive_Ext return String is begin return "a"; end Archive_Ext; @@ -150,11 +150,13 @@ package body MLib.Tgt is ----------------------------- function Get_Target_Suffix return String is - Target_Name : String_Ptr := Sdefault.Target_Name; + Target_Name : constant String_Ptr := Sdefault.Target_Name; Index : Positive := Target_Name'First; + begin - while ((Index < Target_Name'Last) and then - (Target_Name (Index + 1) /= '-')) loop + while Index < Target_Name'Last + and then Target_Name (Index + 1) /= '-' + loop Index := Index + 1; end loop; diff --git a/gcc/ada/5ztaprop.adb b/gcc/ada/5ztaprop.adb index 6ee3f80..8bbbf0e 100644 --- a/gcc/ada/5ztaprop.adb +++ b/gcc/ada/5ztaprop.adb @@ -717,9 +717,8 @@ package body System.Task_Primitives.Operations is procedure Yield (Do_Yield : Boolean := True) is pragma Unreferenced (Do_Yield); - Result : int; - + pragma Unreferenced (Result); begin Result := taskDelay (0); end Yield; diff --git a/gcc/ada/6vcpp.adb b/gcc/ada/6vcpp.adb index 864e237..a0a8a49 100644 --- a/gcc/ada/6vcpp.adb +++ b/gcc/ada/6vcpp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2002, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-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,7 +31,7 @@ -- -- ------------------------------------------------------------------------------ --- This is the OpenVMS/Alpha DEC C++ (cxx) version of this package. +-- This is the OpenVMS/Alpha DEC C++ (cxx) version of this package with Ada.Tags; use Ada.Tags; with System; use System; @@ -102,14 +102,14 @@ package body Interfaces.CPP is function Displaced_This (Current_This : System.Address; Vptr : Vtable_Ptr; - Position : Positive) - return System.Address + Position : Positive) return System.Address is pragma Warnings (Off, Vptr); pragma Warnings (Off, Position); begin return Current_This; --- + Storage_Offset (Vptr.Prims_Ptr (Position).Delta1); + -- + Storage_Offset (Vptr.Prims_Ptr (Position).Delta1); + -- why is above line commented out ??? end Displaced_This; ----------------------- @@ -118,8 +118,7 @@ package body Interfaces.CPP is function CPP_CW_Membership (Obj_Tag : Vtable_Ptr; - Typ_Tag : Vtable_Ptr) - return Boolean + Typ_Tag : Vtable_Ptr) return Boolean is Pos : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth; begin @@ -153,14 +152,24 @@ package body Interfaces.CPP is return T.TSD.Idepth; end CPP_Get_Inheritance_Depth; - ------------------------- + ----------------------- + -- CPP_Get_RC_Offset -- + ----------------------- + + function CPP_Get_RC_Offset (T : Vtable_Ptr) return SSE.Storage_Offset is + pragma Warnings (Off, T); + begin + return 0; + end CPP_Get_RC_Offset; + + ----------------------------- -- CPP_Get_Prim_Op_Address -- - ------------------------- + ----------------------------- function CPP_Get_Prim_Op_Address (T : Vtable_Ptr; - Position : Positive) - return Address is + Position : Positive) return Address + is begin return T.Prims_Ptr (Position).Pfn; end CPP_Get_Prim_Op_Address; @@ -189,14 +198,14 @@ package body Interfaces.CPP is -------------------- procedure CPP_Inherit_DT - (Old_T : Vtable_Ptr; - New_T : Vtable_Ptr; + (Old_T : Vtable_Ptr; + New_T : Vtable_Ptr; Entry_Count : Natural) is begin if Old_T /= null then - New_T.Prims_Ptr (1 .. Entry_Count) - := Old_T.Prims_Ptr (1 .. Entry_Count); + New_T.Prims_Ptr (1 .. Entry_Count) := + Old_T.Prims_Ptr (1 .. Entry_Count); end if; end CPP_Inherit_DT; @@ -208,8 +217,8 @@ package body Interfaces.CPP is (Old_TSD : Address; New_Tag : Vtable_Ptr) is - TSD : constant Type_Specific_Data_Ptr - := To_Type_Specific_Data_Ptr (Old_TSD); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (Old_TSD); New_TSD : Type_Specific_Data renames New_Tag.TSD.all; @@ -268,6 +277,17 @@ package body Interfaces.CPP is T.Prims_Ptr (Position).Pfn := Value; end CPP_Set_Prim_Op_Address; + ----------------------- + -- CPP_Set_RC_Offset -- + ----------------------- + + procedure CPP_Set_RC_Offset (T : Vtable_Ptr; Value : SSE.Storage_Offset) is + pragma Warnings (Off, T); + pragma Warnings (Off, Value); + begin + null; + end CPP_Set_RC_Offset; + ------------------------------- -- CPP_Set_Remotely_Callable -- ------------------------------- @@ -293,8 +313,7 @@ package body Interfaces.CPP is ------------------- function Expanded_Name (T : Vtable_Ptr) return String is - Result : Cstring_Ptr := T.TSD.Expanded_Name; - + Result : constant Cstring_Ptr := T.TSD.Expanded_Name; begin return Result (1 .. Length (Result)); end Expanded_Name; @@ -304,8 +323,7 @@ package body Interfaces.CPP is ------------------ function External_Tag (T : Vtable_Ptr) return String is - Result : Cstring_Ptr := T.TSD.External_Tag; - + Result : constant Cstring_Ptr := T.TSD.External_Tag; begin return Result (1 .. Length (Result)); end External_Tag; @@ -325,16 +343,4 @@ package body Interfaces.CPP is return Len - 1; end Length; - procedure CPP_Set_RC_Offset (T : Vtable_Ptr; Value : SSE.Storage_Offset) is - pragma Warnings (Off, T); - pragma Warnings (Off, Value); - begin - null; - end CPP_Set_RC_Offset; - - function CPP_Get_RC_Offset (T : Vtable_Ptr) return SSE.Storage_Offset is - pragma Warnings (Off, T); - begin - return 0; - end CPP_Get_RC_Offset; end Interfaces.CPP; diff --git a/gcc/ada/6vcstrea.adb b/gcc/ada/6vcstrea.adb index 0469019..ff0f88d 100644 --- a/gcc/ada/6vcstrea.adb +++ b/gcc/ada/6vcstrea.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2004 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -38,6 +38,14 @@ package body Interfaces.C_Streams is use type System.CRTL.size_t; + -- Substantial rewriting is needed here. These functions are far too + -- long to be inlined. They should be rewritten to be small helper + -- functions that are inlined, and then call the real routines.??? + + -- Alternatively, provide a separate spec for VMS, in which case we + -- could reduce the amount of junk bodies in the other cases by + -- interfacing directly in the spec.??? + ------------ -- fread -- ------------ @@ -46,31 +54,36 @@ package body Interfaces.C_Streams is (buffer : voids; size : size_t; count : size_t; - stream : FILEs) - return size_t + stream : FILEs) return size_t is Get_Count : size_t := 0; + type Buffer_Type is array (size_t range 1 .. count, size_t range 1 .. size) of Character; type Buffer_Access is access Buffer_Type; function To_BA is new Unchecked_Conversion (voids, Buffer_Access); - BA : Buffer_Access := To_BA (buffer); + + BA : constant Buffer_Access := To_BA (buffer); Ch : int; - begin + begin -- This Fread goes with the Fwrite below. -- The C library fread sometimes can't read fputc generated files. for C in 1 .. count loop for S in 1 .. size loop Ch := fgetc (stream); + if Ch = EOF then return Get_Count; end if; + BA.all (C, S) := Character'Val (Ch); end loop; + Get_Count := Get_Count + 1; end loop; + return Get_Count; end fread; @@ -83,31 +96,36 @@ package body Interfaces.C_Streams is index : size_t; size : size_t; count : size_t; - stream : FILEs) - return size_t + stream : FILEs) return size_t is Get_Count : size_t := 0; + type Buffer_Type is array (size_t range 1 .. count, size_t range 1 .. size) of Character; type Buffer_Access is access Buffer_Type; function To_BA is new Unchecked_Conversion (voids, Buffer_Access); - BA : Buffer_Access := To_BA (buffer); + + BA : constant Buffer_Access := To_BA (buffer); Ch : int; - begin + begin -- This Fread goes with the Fwrite below. -- The C library fread sometimes can't read fputc generated files. for C in 1 + index .. count + index loop for S in 1 .. size loop Ch := fgetc (stream); + if Ch = EOF then return Get_Count; end if; + BA.all (C, S) := Character'Val (Ch); end loop; + Get_Count := Get_Count + 1; end loop; + return Get_Count; end fread; @@ -119,17 +137,18 @@ package body Interfaces.C_Streams is (buffer : voids; size : size_t; count : size_t; - stream : FILEs) - return size_t + stream : FILEs) return size_t is Put_Count : size_t := 0; + type Buffer_Type is array (size_t range 1 .. count, size_t range 1 .. size) of Character; type Buffer_Access is access Buffer_Type; function To_BA is new Unchecked_Conversion (voids, Buffer_Access); - BA : Buffer_Access := To_BA (buffer); - begin + BA : constant Buffer_Access := To_BA (buffer); + + begin -- Fwrite on VMS has the undesirable effect of always generating at -- least one record of output per call, regardless of buffering. To -- get around this, we do multiple fputc calls instead. @@ -140,8 +159,10 @@ package body Interfaces.C_Streams is return Put_Count; end if; end loop; + Put_Count := Put_Count + 1; end loop; + return Put_Count; end fwrite; @@ -153,12 +174,11 @@ package body Interfaces.C_Streams is (stream : FILEs; buffer : chars; mode : int; - size : size_t) - return int + size : size_t) return int is use type System.Address; - begin + begin -- In order for the above fwrite hack to work, we must always buffer -- stdout and stderr. Is_regular_file on VMS cannot detect when -- these are redirected to a file, so checking for that condition diff --git a/gcc/ada/7staprop.adb b/gcc/ada/7staprop.adb index 6ce0b46..6e71f45 100644 --- a/gcc/ada/7staprop.adb +++ b/gcc/ada/7staprop.adb @@ -725,7 +725,7 @@ package body System.Task_Primitives.Operations is procedure Yield (Do_Yield : Boolean := True) is Result : Interfaces.C.int; - + pragma Unreferenced (Result); begin if Do_Yield then Result := sched_yield; diff --git a/gcc/ada/7stpopsp.adb b/gcc/ada/7stpopsp.adb index 1b84b8f..fb8d731 100644 --- a/gcc/ada/7stpopsp.adb +++ b/gcc/ada/7stpopsp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2002, Free Software Fundation, Inc. -- +-- Copyright (C) 1992-2003, Free Software Fundation, Inc. -- -- -- -- 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- -- @@ -43,7 +43,6 @@ package body Specific is procedure Initialize (Environment_Task : Task_ID) is pragma Warnings (Off, Environment_Task); Result : Interfaces.C.int; - begin Result := pthread_key_create (ATCB_Key'Access, null); pragma Assert (Result = 0); @@ -64,7 +63,6 @@ package body Specific is procedure Set (Self_Id : Task_ID) is Result : Interfaces.C.int; - begin Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id)); pragma Assert (Result = 0); diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a49c825..c554b71 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,255 @@ +2004-01-05 Robert Dewar <dewar@gnat.com> + + * 1ssecsta.ads: Default_Secondary_Stack is not a constant since it may + be modified by the binder generated main program if the -D switch is + used. + + * 4onumaux.ads, 4znumaux.ads: Add Pure_Function pragmas for all + imported functions (since now we expect this to be done for imported + functions) + + * 5vtaprop.adb: Add several ??? for sections requiring more comments + Minor reformatting throughout + + * 5zinit.adb: Minor reformatting + Add 2004 to copyright date + Minor changes to avoid -gnatwa warnings + Correct some instances of using OR instead of OR ELSE (noted while + doing reformatting) + + * sprint.adb: Minor updates to avoid -gnatwa warnings + + * s-secsta.ads, s-secsta.adb: + (SS_Get_Max): New function to obtain high water mark for ss stack + Default_Secondary_Stack is not a constant since it may be modified by + the binder generated main program if the -D switch is used. + + * switch-b.adb: New -Dnnn switch for binder + + * switch-c.adb: + Make -gnatg imply all warnings currently in -gnatwa + + * vms_conv.adb: Minor reformatting + Add 2004 to copyright notice + Add 2004 to printed copyright notice + + * 3vexpect.adb, 4zsytaco.adb, 3wsocthi.adb, 3zsocthi.adb, + 3zsocthi.adb, 56taprop.adb, 56tpopsp.adb, 5amastop.adb, + 5aml-tgt.adb, 5ataprop.adb, 5ataprop.adb, 5atpopsp.adb, + 5ftaprop.adb, 5ginterr.adb, 5gmastop.adb, 5gml-tgt.adb, + 5gtaprop.adb, 5hml-tgt.adb, 5hml-tgt.adb, 5hml-tgt.adb, + 5htaprop.adb, 5htraceb.adb, 5itaprop.adb, 5lml-tgt.adb, + 5sml-tgt.adb, 5staprop.adb, 5staprop.adb, 5stpopsp.adb, + 5vasthan.adb, 5vinmaop.adb, 5vinterr.adb, 5vtaprop.adb, + 5vml-tgt.adb, 5vtaprop.adb, 5wosprim.adb, 5wtaprop.adb, + 5zinterr.adb, 5zintman.adb, 5zml-tgt.adb, 5ztaprop.adb, + 6vcpp.adb, 6vcstrea.adb, 7staprop.adb, 7stpopsp.adb, + vxaddr2line.adb, vxaddr2line.adb, xref_lib.adb, xr_tabls.adb, + xr_tabls.ads, s-tasdeb.adb, s-tasdeb.adb, sem_res.ads, + sem_util.adb, sem_util.adb, sem_util.ads, s-interr.adb, + checks.adb, clean.adb, cstand.adb, einfo.ads, + einfo.adb, exp_aggr.adb, exp_ch11.adb, exp_ch3.adb, + exp_ch4.adb, exp_ch5.adb, exp_ch7.adb, exp_ch9.adb, + prj-nmsc.adb, prj-pp.adb, prj-util.adb, sem_attr.adb, + sem_ch10.adb, sem_ch12.adb, sem_ch4.adb, g-dirope.adb, + g-dirope.ads, gnatlbr.adb, i-cstrea.adb, inline.adb, + lib-xref.adb, sem_ch5.adb, sem_ch7.adb, sem_ch8.adb: + Minor reformatting and code clean ups. + Minor changes to prevent -gnatwa warnings + + * ali.adb: Minor reformatting and cleanup of code + Acquire new SS indication of secondary stack use from ali files + + * a-numaux.ads: Add Pure_Function pragmas for all imported functions + (since now we expect this to be done for imported functions) + + * bindgen.adb: Generate call to modify default secondary stack size if + -Dnnn switch given + + * bindusg.adb: Add line for new -D switch + + * exp_aggr.adb (Type_May_Have_Bit_Aligned_Components): More appropriate + replacement name for Type_May_Have_Non_Bit_Aligned_Components! + Add circuitry for both records and arrays to avoid gigi + processing if the type involved has non-bit-aligned components + + * exp_ch5.adb (Expand_Assign_Array): Avoid assumption that + N_String_Literal node always references an E_String_Literal_Subtype + entity. This may not be true in the future. + (Possible_Bit_Aligned_Component): Move processing of + Component_May_Be_Bit_Aligned from exp_ch5 to exp_util + + * exp_ch6.adb (Expand_Thread_Body): Pick up + Default_Secondary_Stack_Size as variable so that we get value modified + by possible -Dnnn binder parameter. + + * exp_util.adb (Component_May_Be_Bit_Aligned): New function. + (Type_May_Have_Bit_Aligned_Components): New function. + + * exp_util.ads (Component_May_Be_Bit_Aligned): New function. + (Type_May_Have_Bit_Aligned_Components): New function. + + * fe.h: (Set_Identifier_Casing): Fix prototype. + Add declaration for Sem_Elim.Eliminate_Error_Msg. + Minor reformatting. + + * freeze.adb (Freeze_Entity): Add RM reference to error message about + importing constant atomic/volatile objects. + (Freeze_Subprogram): Reset Is_Pure indication for imported subprogram + unless explicit Pure_Function pragma given, to avoid insidious bug of + call to non-pure imported function getting eliminated. + + * gnat1drv.adb, gnatbind.adb, gnatchop.adb, gnatfind.adb, + gnatls.adb, gnatlink.adb, gnatmem.adb, gnatname.adb, gnatsym.adb, + gnatxref.adb, gprcmd.adb, gprep.adb, make.adb: Minor reformatting + Add 2004 to printed copyright notice + + * lib-writ.ads, lib-writ.adb: Put new SS flag in ali file if secondary + stack used. + + * Makefile.rtl: Add entry for g-sestin.o + g-sestin.ads: New file. + + * mdll.adb: Minor changes to avoid -gnatwa warnings + + * mlib-tgt.adb: Minor reformatting + + * opt.ads: New parameter Default_Secondary_Stack_Size (GNATBIND) + New switch Sec_Stack_Used (GNAT, GNATBIND) + Make Default_Secondary_Stack_Size a variable instead of a constant, + so that it can be modified by the new -Dnnn bind switch. + + * rtsfind.adb (Load_Fail): Give full error message in configurable + run-time mode if all_errors mode is set. This was not done in the case + of a file not found, which was an oversight. + Note if secondary stack unit is used by compiler. + + * sem_elab.adb (Check_A_Call): Rewrite to avoid trying to put + ineffective elaborate all pragmas on non-visible packages (this + happened when a renamed subprogram was called). Now the elaborate all + always goes on the package containing the renaming rather than the one + containing the renamed subprogram. + + * sem_elim.ads, sem_elim.adb (Eliminate_Error_Msg): New procedure + (Process_Eliminate_Pragma): Add parameter to capture pragma location. + + * sem_eval.adb (Eval_String_Literal): Do not assume that string literal + has an Etype that references an E_String_Literal. + (Eval_String_Literal): Avoid assumption that N_String_Literal node + always references an E_String_Literal_Subtype entity. This may not + be true in the future. + + * sem_prag.adb (Process_Eliminate_Pragma): Add parameter to capture + pragma location. + + * sem_res.adb (Resolve): Specialize msg for function name used in proc + call. + +2004-01-05 Ed Falis <falis@gnat.com> + + * g-debuti.adb: Replaced direct boolean operator with short-circuit + form. + +2004-01-05 Vincent Celier <celier@gnat.com> + + * bld.adb: Minor comment updates + (Process_Declarative_Items): Correct incorrect name (Index_Name instead + of Item_Name). + + * make.adb (Gnatmake): Special process for files to compile/check when + -B is specified. Fail when there are only foreign mains in attribute + Main of the project file and -B is not specified. Do not skip bind/link + steps when -B is specified. + + * makeusg.adb: Document new switch -B + + * opt.ads (Build_Bind_And_Link_Full_Project): New Boolean flag + + * switch-m.adb: (Scan_Make_Switches): Process -B switch + + * vms_data.ads: Add new GNAT PRETTY qualifier + /FORM_FEED_AFTER_PRAGMA_PAGE for switch -ff + +2004-01-05 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> + + * trans.c (tree_transform, case N_Free_Statement): Handle thin pointer + case. + + * misc.c (gnat_printable_name): If VERBOSITY is 2, call + Set_Identifier_Casing. + + * decl.c (gnat_to_gnu_entity, E_Function): Give error if return type + has size that overflows. + +2004-01-05 Gary Dismukes <dismukes@gnat.com> + + * exp_ch4.adb (Expand_Array_Comparison): Add Boolean constant to avoid + -gnatwa warning on static condition. + +2004-01-05 Doug Rupp <rupp@gnat.com> + + * link.c: (shared_libgnat_default) [VMS]: Change to STATIC. + +2004-01-05 Arnaud Charlet <charlet@act-europe.fr> + + * Makefile.in: Install ali files using INSTALL_DATA_DATE to preserve + all attributes, including read-only attribute. + +2004-01-05 Pascal Obry <obry@gnat.com> + + * bindgen.adb (Gen_Object_Files_Options): Generate the new shared + library naming scheme. + + * mlib-prj.adb (Build_Library): Generate different names for the static + or dynamic version of the GNAT runtime. This is needed to support the + new shared library naming scheme. + (Process_Binder_File): Add detection of shared library in binder file + based on the new naming scheme. + + * gnatlink.adb (Process_Binder_File): Properly detect the new naming + scheme for the shared runtime libraries. + + * Makefile.in: + (LIBRARY_VERSION) [VMS]: Convert all . to _ to conform to new naming + scheme. + (install-gnatlib): Do not create symlinks for shared libraries. + (gnatlib-shared-default): Idem. + (gnatlib-shared-dual-win32): New target. Not used for now as the + auto-import feature does not support arrays/records. + (gnatlib-shared-win32): Do not create copy for the shared libraries. + (gnatlib-shared-vms): Fix shared runtime libraries names. + + * osint.ads, osint.adb (Shared_Lib): New routine, returns the target + dependent runtime shared library name. + +2004-01-05 Vasiliy Fofanov <fofanov@act-europe.fr> + + * osint.adb (Read_Library_Info): Remove bogus check if ALI is older + than the object. + +2004-01-05 Ed Schonberg <schonberg@gnat.com> + + * sem_ch4.adb (Analyze_Allocator): Check restriction on dynamic + protected objects when allocator has a subtype indication, not a + qualified expression. Note that qualified expressions may have to be + checked when limited aggregates are implemented. + + * sem_prag.adb (Analyze_Pragma, case Import): If enclosing package is + pure, emit warning. + (Analyze_Pragma, case Pure_Function): If enclosing package is pure and + subprogram is imported, remove warning. + +2004-01-05 Geert Bosch <bosch@gnat.com> + + * s-poosiz.adb: Update copyright notice. + (Allocate): Use Task_Lock to protect against concurrent access. + (Deallocate): Likewise. + +2004-01-05 Joel Brobecker <brobecker@gnat.com> + + * s-stalib.adb (Elab_Final_Code): Add missing year in date inside ??? + comment. + 2003-12-23 Kelley Cook <kcook@gcc.gnu.org> * gnat_ug.texi: Force a CVS commit by updating copyright. diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index b20402c..79b4fc2 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -1207,6 +1207,7 @@ endif # This command transforms (YYYYMMDD) into YY,MMDD GSMATCH_VERSION := $(shell grep "^ *Gnat_Static_Version_String" $(fsrcpfx)gnatvsn.ads | sed -e 's/.*(\(.*\)).*/\1/' -e 's/\(..\)\(..\)\(....\)/\2,\3/') TOOLS_LIBS_LO := --for-linker=sys\\$$\$$library:trace.exe + LIBRARY_VERSION := $(subst .,_,$(LIB_VERSION)) endif ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),) @@ -1241,6 +1242,8 @@ ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),) EXTRA_GNATMAKE_OBJS = mdll.o mdll-utl.o mdll-fil.o EXTRA_GNATRTL_NONTASKING_OBJS = g-regist.o soext = .dll +# ??? This will be replaced by gnatlib-shared-dual-win32 when GNAT auto-import +# support for array/record will be done. GNATLIB_SHARED = gnatlib-shared-win32 LIBRARY_VERSION := $(LIB_VERSION) endif @@ -1688,7 +1691,7 @@ install-gnatlib: ../stamp-gnatlib -$(INSTALL_DATA) rts/Makefile.prolog $(DESTDIR)$(ADA_SHARE_MAKE_DIR) -$(INSTALL_DATA) rts/Makefile.generic $(DESTDIR)$(ADA_SHARE_MAKE_DIR) for file in rts/*.ali; do \ - $(INSTALL_DATA) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \ + $(INSTALL_DATA_DATE) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \ done -$(INSTALL_DATA) rts/g-trasym$(objext) $(DESTDIR)$(ADA_RTL_OBJ_DIR) -for file in rts/*$(arext);do \ @@ -1707,11 +1710,6 @@ else $(INSTALL) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \ done endif - if [ -f rts/libgnat-*$(soext) ]; then \ - (cd $(DESTDIR)$(ADA_RTL_OBJ_DIR) && \ - $(LN_S) libgnat-*$(soext) libgnat$(soext) && \ - $(LN_S) libgnarl-*$(soext) libgnarl$(soext)) \ - fi # This copy must be done preserving the date on the original file. for file in rts/*.adb rts/*.ads; do \ $(INSTALL_DATA_DATE) $$file $(DESTDIR)$(ADA_INCLUDE_DIR); \ @@ -1898,8 +1896,6 @@ gnatlib-shared-default: -o libgnarl-$(LIBRARY_VERSION)$(soext) \ $(GNATRTL_TASKING_OBJS) \ $(SO_OPTS)libgnarl-$(LIBRARY_VERSION)$(soext) $(THREADSLIB) - cd rts; $(LN_S) libgnat-$(LIBRARY_VERSION)$(soext) libgnat$(soext) - cd rts; $(LN_S) libgnarl-$(LIBRARY_VERSION)$(soext) libgnarl$(soext) gnatlib-shared-dual: $(MAKE) $(FLAGS_TO_PASS) \ @@ -1916,10 +1912,25 @@ gnatlib-shared-dual: gnatlib $(MV) libgna*$(soext) rts -# Note that on Win32 the auto-import does not work for DLL, so on the -# platform we have a specific setup. The libgnat.dll contains only -# non-tasking objects and libgnarl.dll contains tasking and non-tasking -# objects. A tasking program must be linked with libgnarl.dll only. +gnatlib-shared-dual-win32: + $(MAKE) $(FLAGS_TO_PASS) \ + GNATLIBFLAGS="$(GNATLIBFLAGS)" \ + GNATLIBCFLAGS="$(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS)" \ + THREAD_KIND="$(THREAD_KIND)" \ + gnatlib-shared-win32 + $(MV) rts/libgna*$(soext) . + $(RM) ../stamp-gnatlib2 + $(MAKE) $(FLAGS_TO_PASS) \ + GNATLIBFLAGS="$(GNATLIBFLAGS)" \ + GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ + THREAD_KIND="$(THREAD_KIND)" \ + gnatlib + $(MV) libgna*$(soext) rts + +# ??? we need to add the option to support auto-import of arrays/records to +# the GNATLIBFLAGS when this will be supported by GNAT. At this point we will +# use the gnatlib-shared-dual-win32 target to build the GNAT runtimes on +# Windows. gnatlib-shared-win32: $(MAKE) $(FLAGS_TO_PASS) \ GNATLIBFLAGS="$(GNATLIBFLAGS)" \ @@ -1936,8 +1947,6 @@ gnatlib-shared-win32: $(GNATRTL_TASKING_OBJS) \ $(SO_OPTS)libgnarl-$(LIBRARY_VERSION)$(soext) \ $(THREADSLIB) -Wl,libgnat-$(LIBRARY_VERSION)$(soext) - cd rts; $(LN_S) libgnat-$(LIBRARY_VERSION)$(soext) libgnat$(soext) - cd rts; $(LN_S) libgnarl-$(LIBRARY_VERSION)$(soext) libgnarl$(soext) gnatlib-shared-vms: $(MAKE) $(FLAGS_TO_PASS) \ @@ -1951,7 +1960,7 @@ gnatlib-shared-vms: $(SHLIB_SYMVEC) >> SYMVEC_$$$$.opt && \ echo "case_sensitive=NO" >> SYMVEC_$$$$.opt && \ ../../xgcc -g -B../../ -nostartfiles -shared -shared-libgcc \ - -o libgnat_s$(soext) libgnat.a \ + -o libgnat_$(LIBRARY_VERSION)$(soext) libgnat.a \ sys\$$library:trace.exe \ --for-linker=/noinform \ --for-linker=SYMVEC_$$$$.opt \ @@ -1961,8 +1970,8 @@ gnatlib-shared-vms: $(SHLIB_SYMVEC) >> SYMVEC_$$$$.opt && \ echo "case_sensitive=NO" >> SYMVEC_$$$$.opt && \ ../../xgcc -g -B../../ -nostartfiles -shared -shared-libgcc \ - -o libgnarl_s$(soext) \ - libgnarl.a libgnat_s$(soext) \ + -o libgnarl_$(LIBRARY_VERSION)$(soext) \ + libgnarl.a libgnat_$(LIBRARY_VERSION)$(soext) \ sys\$$library:trace.exe \ --for-linker=/noinform \ --for-linker=SYMVEC_$$$$.opt \ diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 0fabb1d..9be0d72 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -18,7 +18,7 @@ #the Free Software Foundation, 59 Temple Place - Suite 330, #Boston, MA 02111-1307, USA. -# This makefile fragment is included into the ada Makefile (both Unix +# This makefile fragment is included in the ada Makefile (both Unix # and NT and VMS versions). # It's purpose is to allow the separate maintainence of the list of @@ -236,6 +236,7 @@ GNATRTL_NONTASKING_OBJS= \ g-pehage$(objext) \ g-regexp$(objext) \ g-regpat$(objext) \ + g-sestin$(objext) \ g-soccon$(objext) \ g-socket$(objext) \ g-socthi$(objext) \ diff --git a/gcc/ada/a-numaux.ads b/gcc/ada/a-numaux.ads index 5d75217..61d2dfa 100644 --- a/gcc/ada/a-numaux.ads +++ b/gcc/ada/a-numaux.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (C Library Version, non-x86) -- -- -- --- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2003 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- -- @@ -39,9 +39,11 @@ -- One advantage of using this package is that it will interface directly to -- hardware instructions, such as the those provided on the Intel x86. --- Note: there are two versions of this package. One using the normal IEEE --- 64-bit double format (which is this version), and one using 80-bit x86 --- long double (see file 4onumaux.ads). +-- This version is for use with normal Unix math functions. Alternative +-- packages are used on OpenVMS (different import names), VxWorks (no +-- need for the -lm Linker_Options), and on the x86 (where we have two +-- versions one using inline ASM, and one importing from the C long +-- routines that take 80-bit arguments). package Ada.Numerics.Aux is pragma Pure (Aux); @@ -49,48 +51,61 @@ pragma Pure (Aux); pragma Linker_Options ("-lm"); type Double is digits 15; - pragma Float_Representation (IEEE_Float, Double); - -- Type Double is the type used to call the C routines. Note that this - -- is IEEE format even when running on VMS with Vax_Float representation - -- since we use the IEEE version of the C library with VMS. + -- Type Double is the type used to call the C routines + + -- We import these functions directly from C. Note that we label them + -- all as pure functions, because indeed all of them are in fact pure! function Sin (X : Double) return Double; pragma Import (C, Sin, "sin"); + pragma Pure_Function (Sin); function Cos (X : Double) return Double; pragma Import (C, Cos, "cos"); + pragma Pure_Function (Cos); function Tan (X : Double) return Double; pragma Import (C, Tan, "tan"); + pragma Pure_Function (Tan); function Exp (X : Double) return Double; pragma Import (C, Exp, "exp"); + pragma Pure_Function (Exp); function Sqrt (X : Double) return Double; pragma Import (C, Sqrt, "sqrt"); + pragma Pure_Function (Sqrt); function Log (X : Double) return Double; pragma Import (C, Log, "log"); + pragma Pure_Function (Log); function Acos (X : Double) return Double; pragma Import (C, Acos, "acos"); + pragma Pure_Function (Acos); function Asin (X : Double) return Double; pragma Import (C, Asin, "asin"); + pragma Pure_Function (Asin); function Atan (X : Double) return Double; pragma Import (C, Atan, "atan"); + pragma Pure_Function (Atan); function Sinh (X : Double) return Double; pragma Import (C, Sinh, "sinh"); + pragma Pure_Function (Sinh); function Cosh (X : Double) return Double; pragma Import (C, Cosh, "cosh"); + pragma Pure_Function (Cosh); function Tanh (X : Double) return Double; pragma Import (C, Tanh, "tanh"); + pragma Pure_Function (Tanh); function Pow (X, Y : Double) return Double; pragma Import (C, Pow, "pow"); + pragma Pure_Function (Pow); end Ada.Numerics.Aux; diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 0ad9d6e..37e62de 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -92,7 +92,6 @@ package body ALI is Task_Dispatching_Policy_Specified := ' '; Unreserve_All_Interrupts_Specified := False; Zero_Cost_Exceptions_Specified := False; - end Initialize_ALI; -------------- @@ -143,8 +142,9 @@ package body ALI is function Getc return Character; -- Get next character, bumping P past the character obtained - function Get_Name (Lower : Boolean := False; - Ignore_Spaces : Boolean := False) return Name_Id; + function Get_Name + (Lower : Boolean := False; + Ignore_Spaces : Boolean := False) return Name_Id; -- Skip blanks, then scan out a name (name is left in Name_Buffer with -- length in Name_Len, as well as being returned in Name_Id form). -- If Lower is set to True then the Name_Buffer will be converted to @@ -175,6 +175,10 @@ package body ALI is procedure Skip_Space; -- Skip past white space (blanks or horizontal tab) + procedure Skipc; + -- Skip past next character, does not affect value in C. This call + -- is like calling Getc and ignoring the returned result. + --------------------- -- At_End_Of_Field -- --------------------- @@ -480,6 +484,17 @@ package body ALI is end loop; end Skip_Space; + ----------- + -- Skipc -- + ----------- + + procedure Skipc is + begin + if P /= T'Last then + P := P + 1; + end if; + end Skipc; + -- Start of processing for Scan_ALI begin @@ -706,6 +721,8 @@ package body ALI is Normalize_Scalars_Specified := True; NS_Found := True; + -- Invalid switch starting with N + else Fatal_Error; end if; @@ -716,11 +733,26 @@ package body ALI is Queuing_Policy_Specified := Getc; ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified; - -- Processing for SL + -- Processing fir flags starting with S elsif C = 'S' then - Checkc ('L'); - ALIs.Table (Id).Interface := True; + C := Getc; + + -- Processing for SL + + if C = 'L' then + ALIs.Table (Id).Interface := True; + + -- Processing for SS + + elsif C = 'S' then + Opt.Sec_Stack_Used := True; + + -- Invalid switch starting with S + + else + Fatal_Error; + end if; -- Processing for Tx @@ -729,18 +761,25 @@ package body ALI is ALIs.Table (Id).Task_Dispatching_Policy := Task_Dispatching_Policy_Specified; - -- Processing for UA + -- Processing for switch starting with U elsif C = 'U' then - if Nextc = 'A' then + C := Getc; + + -- Processing for UA + + if C = 'A' then Unreserve_All_Interrupts_Specified := True; - C := Getc; -- Processing for UX - else - Checkc ('X'); + elsif C = 'X' then ALIs.Table (Id).Unit_Exception_Table := True; + + -- Invalid switches starting with U + + else + Fatal_Error; end if; -- Processing for ZX @@ -1487,11 +1526,9 @@ package body ALI is Xref_Entity.Increment_Last; Read_Refs_For_One_Entity : declare - XE : Xref_Entity_Record renames Xref_Entity.Table (Xref_Entity.Last); - - N : Nat; + N : Nat; procedure Read_Instantiation_Reference; -- Acquire instantiation reference. Caller has checked @@ -1621,7 +1658,6 @@ package body ALI is declare Nested_Brackets : Natural := 0; - C : Character; begin loop @@ -1636,7 +1672,7 @@ package body ALI is end if; end case; - C := Getc; + Skipc; end loop; end; @@ -1680,7 +1716,6 @@ package body ALI is Current_File_Num := XR.File_Num; P := P + 1; N := Get_Nat; - else XR.File_Num := Current_File_Num; end if; @@ -1710,7 +1745,6 @@ package body ALI is XE.Last_Xref := Xref.Last; C := Nextc; - end Read_Refs_For_One_Entity; end loop; diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 56b2915..ec98376 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.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- -- @@ -518,9 +518,10 @@ package body Bindgen is Write_Statement_Buffer; -- Generate call to Install_Handler + WBI (""); WBI (" if Handler_Installed = 0 then"); - WBI (" Install_Handler;"); + WBI (" Install_Handler;"); WBI (" end if;"); end if; @@ -536,6 +537,17 @@ package body Bindgen is Write_Statement_Buffer; end if; + -- Generate assignment of default secondary stack size if set + + if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then + WBI (""); + Set_String (" System.Secondary_Stack."); + Set_String ("Default_Secondary_Stack_Size := "); + Set_Int (Opt.Default_Sec_Stack_Size); + Set_Char (';'); + Write_Statement_Buffer; + end if; + -- Generate elaboration calls WBI (""); @@ -613,6 +625,13 @@ package body Bindgen is Set_String (""";"); Write_Statement_Buffer; + -- Generate declaration for secondary stack default if needed + + if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then + WBI (" extern int system__secondary_stack__" & + "default_secondary_stack_size;"); + end if; + WBI (""); -- Code for normal case (standard library not suppressed) @@ -742,6 +761,17 @@ package body Bindgen is Write_Statement_Buffer; end if; + -- Generate assignment of default secondary stack size if set + + if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then + WBI (""); + Set_String (" system__secondary_stack__"); + Set_String ("default_secondary_stack_size = "); + Set_Int (Opt.Default_Sec_Stack_Size); + Set_Char (';'); + Write_Statement_Buffer; + end if; + -- Generate elaboration calls WBI (""); @@ -1862,12 +1892,24 @@ package body Bindgen is if With_GNARL then Name_Len := 0; - Add_Str_To_Name_Buffer ("-lgnarl"); + + if Opt.Shared_Libgnat then + Add_Str_To_Name_Buffer (Shared_Lib ("gnarl")); + else + Add_Str_To_Name_Buffer ("-lgnarl"); + end if; + Write_Linker_Option; end if; Name_Len := 0; - Add_Str_To_Name_Buffer ("-lgnat"); + + if Opt.Shared_Libgnat then + Add_Str_To_Name_Buffer (Shared_Lib ("gnat")); + else + Add_Str_To_Name_Buffer ("-lgnat"); + end if; + Write_Linker_Option; end if; @@ -1983,6 +2025,12 @@ package body Bindgen is WBI ("with System.Scalar_Values;"); end if; + -- Generate with of System.Secondary_Stack if active + + if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then + WBI ("with System.Secondary_Stack;"); + end if; + Resolve_Binder_Options; if not Suppress_Standard_Library_On_Target then @@ -2698,7 +2746,6 @@ package body Bindgen is ---------------------------- procedure Public_Version_Warning is - Time : constant Int := Time_From_Last_Bind; -- Constants to help defining periods @@ -2738,13 +2785,18 @@ package body Bindgen is -- Do not emit the message if the last message was emitted in the -- specified period taking into account the number of units. + pragma Warnings (Off); + -- Turn off warning of constant condition, which may happen here + -- depending on the choice of constants in the above declarations. + if Nb_Unit < Large and then Time <= Period_Small then return; - elsif Time <= Period_Large then return; end if; + pragma Warnings (On); + Write_Eol; Write_Str ("IMPORTANT NOTICE:"); Write_Eol; diff --git a/gcc/ada/bindusg.adb b/gcc/ada/bindusg.adb index c5ccab9..e5bae21 100644 --- a/gcc/ada/bindusg.adb +++ b/gcc/ada/bindusg.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- -- @@ -73,6 +73,11 @@ begin Write_Str (" -C Generate binder program in C"); Write_Eol; + -- Line for D switch + + Write_Str (" -Dnnn Default secondary stack size = nnn bytes"); + Write_Eol; + -- Line for -e switch Write_Str (" -e Output complete list of elabor"); diff --git a/gcc/ada/bld.adb b/gcc/ada/bld.adb index 492f205..4cecd56 100644 --- a/gcc/ada/bld.adb +++ b/gcc/ada/bld.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 2002-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- -- @@ -66,12 +66,12 @@ package body Bld is Copyright_Displayed : Boolean := False; -- To avoid displaying the Copyright line several times - Usage_Displayed : Boolean := False; + Usage_Displayed : Boolean := False; -- To avoid displaying the usage several times type Expression_Kind_Type is (Undecided, Static_String, Other); - Expression_Kind : Expression_Kind_Type := Undecided; + Expression_Kind : Expression_Kind_Type := Undecided; -- After procedure Expression has been called, this global variable -- indicates if the expression is a static string or not. -- If it is a static string, then Expression_Value (1 .. Expression_Last) @@ -110,16 +110,14 @@ package body Bld is -- The following variables are used to controlled what attributes -- Default_Switches and Switches are allowed in expressions. - Default_Switches_Project : Project_Node_Id := Empty_Node; - Default_Switches_Package : Name_Id := No_Name; - Default_Switches_Language : Name_Id := No_Name; - - Switches_Project : Project_Node_Id := Empty_Node; + Default_Switches_Package : Name_Id := No_Name; + Default_Switches_Language : Name_Id := No_Name; Switches_Package : Name_Id := No_Name; Switches_Language : Source_Kind_Type := Unknown; -- Other attribute references are only allowed in attribute declarations -- of the same package and of the same name. + -- Other_Attribute is True only during attribute declarations other than -- Switches or Default_Switches. @@ -383,8 +381,7 @@ package body Bld is (Static : Boolean; Value : String_Access; Last : Natural; - Default : String) - return String; + Default : String) return String; -- Returns the current suffix, if it is statically known, or "" -- if it is not statically known. Used on C_Suffix, Cxx_Suffix, -- Ada_Body_Suffix and Ada_Spec_Suffix. @@ -435,7 +432,7 @@ package body Bld is Copyright_Displayed := True; Write_Str ("GPR2MAKE "); Write_Str (Gnatvsn.Gnat_Version_String); - Write_Str (" Copyright 2002-2003 Free Software Foundation, Inc."); + Write_Str (" Copyright 2002-2004 Free Software Foundation, Inc."); Write_Eol; Write_Eol; end if; @@ -1175,12 +1172,10 @@ package body Bld is Current_Declarative_Item := Next_Declarative_Item (Current_Declarative_Item); - -- By default, indicate that Default_Switches and Switches - -- attribute references are not allowed in expressions. + -- By default, indicate that we are not declaring attribute + -- Default_Switches or Switches. - Default_Switches_Project := Empty_Node; - Switches_Project := Empty_Node; - Other_Attribute := False; + Other_Attribute := False; -- Write_Line (Project_Node_Kind'Image (Kind_Of (Current_Item))); @@ -1345,7 +1340,6 @@ package body Bld is -- in expressions. if Item_Name = Snames.Name_Default_Switches then - Default_Switches_Project := Project; Default_Switches_Package := Pkg; Default_Switches_Language := Index; @@ -1354,7 +1348,6 @@ package body Bld is -- Switches attribute references are allowed in expressions. elsif Item_Name = Snames.Name_Switches then - Switches_Project := Project; Switches_Package := Pkg; Switches_Language := Source_Kind_Of (Index); @@ -1862,7 +1855,7 @@ package body Bld is end if; end if; - elsif Item_Name = Snames.Name_Ada then + elsif Index_Name = Snames.Name_Ada then -- For "Ada", we set the variable ADA_BODY @@ -1897,9 +1890,9 @@ package body Bld is else Ada_Body_Suffix_Static := Expression_Value - (1 .. Expression_Last) = - Ada_Body_Suffix - (1 .. Ada_Body_Suffix_Last); + (1 .. Expression_Last) = + Ada_Body_Suffix + (1 .. Ada_Body_Suffix_Last); end if; end if; end if; @@ -3511,8 +3504,7 @@ package body Bld is (Static : Boolean; Value : String_Access; Last : Natural; - Default : String) - return String + Default : String) return String is begin if Static then diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 2adb5f7..acd0510 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -463,13 +463,16 @@ package body Checks is Expr : Node_Id; Loc : Source_Ptr; + Alignment_Required : constant Boolean := Maximum_Alignment > 1; + -- Constant to show whether target requires alignment checks + begin -- See if check needed. Note that we never need a check if the -- maximum alignment is one, since the check will always succeed if No (AC) or else not Check_Address_Alignment (AC) - or else Maximum_Alignment = 1 + or else not Alignment_Required then return; end if; @@ -1191,7 +1194,7 @@ package body Checks is N_Full_Type_Declaration then declare - Type_Def : Node_Id := + Type_Def : constant Node_Id := Type_Definition (Original_Node (Parent (T_Typ))); begin diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index 8f38eb3..7759bbb 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-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- -- @@ -370,9 +370,6 @@ package body Clean is Source_File : File_Name_Type; -- Current source file - Full_Source_File : File_Name_Type; - -- Full name of the current source file - Lib_File : File_Name_Type; -- Current library file @@ -401,9 +398,8 @@ package body Clean is while not Empty_Q loop Sources.Set_Last (0); Extract_From_Q (Source_File); - Full_Source_File := Osint.Full_Source_Name (Source_File); - Lib_File := Osint.Lib_File_Name (Source_File); - Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File); + Lib_File := Osint.Lib_File_Name (Source_File); + Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File); -- If we have an existing ALI file that is not read-only, -- process it. @@ -925,7 +921,7 @@ package body Clean is if not Copyright_Displayed then Copyright_Displayed := True; Put_Line ("GNATCLEAN " & Gnatvsn.Gnat_Version_String - & " Copyright 2003 Free Software Foundation, Inc."); + & " Copyright 2003-2004 Free Software Foundation, Inc."); end if; end Display_Copyright; @@ -1156,9 +1152,7 @@ package body Clean is -- Insert_Q -- -------------- - procedure Insert_Q - (Source_File : File_Name_Type) - is + procedure Insert_Q (Source_File : File_Name_Type) is begin -- Do not insert an empty name or an already marked source @@ -1180,6 +1174,7 @@ package body Clean is function Object_File_Name (Source : Name_Id) return String is Src : constant String := Get_Name_String (Source); + begin -- If the source name has an extension, then replace it with -- the Object suffix. diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index c79d602..61ac93e 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -258,10 +258,10 @@ package body CStand is -- by Initialize_Standard in the semantics module. procedure Create_Standard is - Decl_S : List_Id := New_List; + Decl_S : constant List_Id := New_List; -- List of declarations in Standard - Decl_A : List_Id := New_List; + Decl_A : constant List_Id := New_List; -- List of declarations in ASCII Decl : Node_Id; diff --git a/gcc/ada/decl.c b/gcc/ada/decl.c index 85bd27b..2de25fc 100644 --- a/gcc/ada/decl.c +++ b/gcc/ada/decl.c @@ -3255,6 +3255,21 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) each. While doing this, build a copy-out structure if we need one. */ + /* If the return type has a size that overflows, we cannot have + a function that returns that type. This usage doesn't make + sense anyway, so give an error here. */ + if (TYPE_SIZE_UNIT (gnu_return_type) + && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type))) + { + post_error ("cannot return type whose size overflows", + gnat_entity); + gnu_return_type = copy_node (gnu_return_type); + TYPE_SIZE (gnu_return_type) = bitsize_zero_node; + TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node; + TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type; + TYPE_NEXT_VARIANT (gnu_return_type) = 0; + } + for (gnat_param = First_Formal (gnat_entity), parmnum = 0; Present (gnat_param); gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++) diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index f1a9afa..12651a3 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -4660,7 +4660,7 @@ package body Einfo is end Entry_Index_Type; --------------------- - -- First_Component -- + -- 1 -- --------------------- function First_Component (Id : E) return E is @@ -4671,7 +4671,6 @@ package body Einfo is (Is_Record_Type (Id) or else Is_Incomplete_Or_Private_Type (Id)); Comp_Id := First_Entity (Id); - while Present (Comp_Id) loop exit when Ekind (Comp_Id) = E_Component; Comp_Id := Next_Entity (Comp_Id); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 07aa13f..cff7039 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -521,7 +521,7 @@ package Einfo is -- representation clause is present for the corresponding record -- type a that specifies a position for the component, then the -- Component_Clause field of the E_Component entity points to the --- N_Component_Claue node. Set to Empty if no record representation +-- N_Component_Clause node. Set to Empty if no record representation -- clause was present, or if there was no specification for this -- component. @@ -2581,6 +2581,7 @@ package Einfo is -- Present in components and discriminants. Indicates the normalized -- value of First_Bit for the component, i.e. the offset within the -- lowest addressed storage unit containing part or all of the field. +-- Set to No_Uint if no first bit position is assigned yet. -- Normalized_Position (Uint14) -- Present in components and discriminants. Indicates the normalized diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 9c23399..10c35d3 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -264,6 +264,8 @@ package body Exp_Aggr is -- 5. The array component type is tagged, which may necessitate -- reassignment of proper tags. + -- 6. The array component type might have unaligned bit components + function Backend_Processing_Possible (N : Node_Id) return Boolean is Typ : constant Entity_Id := Etype (N); -- Typ is the correct constrained array subtype of the aggregate. @@ -317,7 +319,7 @@ package body Exp_Aggr is return False; end if; - -- Checks 4 (array must not be multi-dimensional Fortran case) + -- Checks 4 (array must not be multi-dimensional Fortran case) if Convention (Typ) = Convention_Fortran and then Number_Dimensions (Typ) > 1 @@ -350,6 +352,12 @@ package body Exp_Aggr is return False; end if; + -- Checks 6 (component type must not have bit aligned components) + + if Type_May_Have_Bit_Aligned_Components (Component_Type (Typ)) then + return False; + end if; + -- Backend processing is possible Set_Compile_Time_Known_Aggregate (N, True); @@ -1924,7 +1932,7 @@ package body Exp_Aggr is -- by Build_Task_Allocate_Block_With_Init_Stmts) declare - Ctype : Entity_Id := Etype (Selector); + Ctype : constant Entity_Id := Etype (Selector); Inside_Allocator : Boolean := False; P : Node_Id := Parent (N); @@ -3520,7 +3528,8 @@ package body Exp_Aggr is function Must_Slide (N : Node_Id; Typ : Entity_Id) return Boolean is - Obj_Type : Entity_Id := Etype (Defining_Identifier (Parent (N))); + Obj_Type : constant Entity_Id := + Etype (Defining_Identifier (Parent (N))); L1, L2, H1, H2 : Node_Id; @@ -4343,6 +4352,12 @@ package body Exp_Aggr is elsif Has_Mutable_Components (Typ) then Convert_To_Assignments (N, Typ); + -- If the type involved has any non-bit aligned components, then + -- we are not sure that the back end can handle this case correctly. + + elsif Type_May_Have_Bit_Aligned_Components (Typ) then + Convert_To_Assignments (N, Typ); + -- In all other cases we generate a proper aggregate that -- can be handled by gigi. diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 16e6544..511923b 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -721,7 +721,7 @@ package body Exp_Ch11 is if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then declare - H : Node_Id := Handler; + H : constant Node_Id := Handler; begin Next_Non_Pragma (Handler); Remove (H); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 1cb9328..bac09db 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -2882,7 +2882,7 @@ package body Exp_Ch3 is begin -- Don't do anything for deferred constants. All proper actions will - -- be expanded during the redeclaration. + -- be expanded during the full declaration. if No (Expr) and Constant_Present (N) then return; @@ -3018,7 +3018,7 @@ package body Exp_Ch3 is -- When we have the appropriate type of aggregate in the -- expression (it has been determined during analysis of the -- aggregate by setting the delay flag), let's perform in - -- place assignment and thus avoid creating a temporay. + -- place assignment and thus avoid creating a temporary. if Is_Delayed_Aggregate (Expr_Q) then Convert_Aggr_In_Object_Decl (N); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 192e898..cc78eef 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.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- -- @@ -654,6 +654,8 @@ package body Exp_Ch4 is Comp : RE_Id; + Stg_Unit_Is_Byte : constant Boolean := System_Storage_Unit = Byte'Size; + function Length_Less_Than_4 (Opnd : Node_Id) return Boolean; -- Returns True if the length of the given operand is known to be -- less than 4. Returns False if this length is known to be four @@ -705,7 +707,7 @@ package body Exp_Ch4 is -- addressing of array components. if not Is_Bit_Packed_Array (Typ1) - and then System_Storage_Unit = Byte'Size + and then Stg_Unit_Is_Byte and then not Java_VM then -- The call we generate is: @@ -5471,8 +5473,8 @@ package body Exp_Ch4 is then return; - elsif (Nkind (Parent (N)) = N_Attribute_Reference - and then Attribute_Name (Parent (N)) = Name_Address) + elsif Nkind (Parent (N)) = N_Attribute_Reference + and then Attribute_Name (Parent (N)) = Name_Address then return; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index a257b27..7c08b2a 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -48,6 +48,7 @@ with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Snames; use Snames; with Stand; use Stand; +with Stringt; use Stringt; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uintp; use Uintp; @@ -75,8 +76,7 @@ package body Exp_Ch5 is L_Type : Entity_Id; R_Type : Entity_Id; Ndim : Pos; - Rev : Boolean) - return Node_Id; + Rev : Boolean) return Node_Id; -- N is an assignment statement which assigns an array value. This routine -- expands the assignment into a loop (or nested loops for the case of a -- multi-dimensional array) to do the assignment component by component. @@ -104,32 +104,11 @@ package body Exp_Ch5 is function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean; -- This function is used in processing the assignment of a record or - -- indexed component. The back end can handle such assignments fine - -- if the objects involved are small (64-bits or less) records or - -- scalar items (including bit-packed arrays represented with modular - -- types) or are both aligned on a byte boundary (starting on a byte - -- boundary, and occupying an integral number of bytes). - -- - -- However, problems arise for records larger than 64 bits, or for - -- arrays (other than bit-packed arrays represented with a modular - -- type) if the component starts on a non-byte boundary, or does - -- not occupy an integral number of bytes (i.e. there are some bits - -- possibly shared with fields at the start or beginning of the - -- component). The back end cannot handle loading and storing such - -- components in a single operation. - -- - -- This function is used to detect the troublesome situation. it is - -- conservative in the sense that it produces True unless it knows - -- for sure that the component is safe (as outlined in the first - -- paragraph above). The code generation for record and array - -- assignment checks for trouble using this function, and if so - -- the assignment is generated component-wise, which the back end - -- is required to handle correctly. - -- - -- Note that in GNAT 3, the back end will reject such components - -- anyway, so the hard work in checking for this case is wasted - -- in GNAT 3, but it's harmless, so it is easier to do it in - -- all cases, rather than conditionalize it in GNAT 5 or beyond. + -- indexed component. The argument N is either the left hand or right + -- hand side of an assignment, and this function determines if there + -- is a record component reference where the record may be bit aligned + -- in a manner that causes trouble for the back end (see description + -- of Sem_Util.Component_May_Be_Bit_Aligned for further details). ------------------------------ -- Change_Of_Representation -- @@ -508,9 +487,12 @@ package body Exp_Ch5 is -- statement, a length check has already been emitted to verify that -- the range of the left-hand side is empty. + -- Note that this code is not executed if we had an assignment of + -- a string literal to a non-bit aligned component of a record, a + -- case which cannot be handled by the backend + elsif Nkind (Rhs) = N_String_Literal then - if Ekind (R_Type) = E_String_Literal_Subtype - and then String_Literal_Length (R_Type) = 0 + if String_Length (Strval (Rhs)) = 0 and then Is_Bit_Packed_Array (L_Type) then Rewrite (N, Make_Null_Statement (Loc)); @@ -731,8 +713,8 @@ package body Exp_Ch5 is elsif Restrictions (No_Implicit_Conditionals) then declare - T : constant Entity_Id := Make_Defining_Identifier (Loc, - Chars => Name_T); + T : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars => Name_T); begin Rewrite (N, @@ -881,8 +863,7 @@ package body Exp_Ch5 is L_Type : Entity_Id; R_Type : Entity_Id; Ndim : Pos; - Rev : Boolean) - return Node_Id + Rev : Boolean) return Node_Id is Loc : constant Source_Ptr := Sloc (N); @@ -2244,8 +2225,8 @@ package body Exp_Ch5 is and then List_Length (Else_Statements (N)) = 1 then declare - Then_Stm : Node_Id := First (Then_Statements (N)); - Else_Stm : Node_Id := First (Else_Statements (N)); + Then_Stm : constant Node_Id := First (Then_Statements (N)); + Else_Stm : constant Node_Id := First (Else_Statements (N)); begin if Nkind (Then_Stm) = N_Return_Statement @@ -3277,39 +3258,10 @@ package body Exp_Ch5 is -- unless it is forced to do so. In the clear means we need -- only the recursive test on the prefix. - if No (Component_Clause (Comp)) then - return Possible_Bit_Aligned_Component (P); - - -- Otherwise we have a component clause, which means that - -- the Esize and Normalized_First_Bit fields are set and - -- contain static values known at compile time. - + if Component_May_Be_Bit_Aligned (Comp) then + return True; else - -- If we know that we have a small (64 bits or less) record - -- or bit-packed array, then everything is fine, since the - -- back end can handle these cases correctly. - - if Esize (Comp) <= 64 - and then (Is_Record_Type (Etype (Comp)) - or else - Is_Bit_Packed_Array (Etype (Comp))) - then - return False; - - -- Otherwise if the component is not byte aligned, we - -- know we have the nasty unaligned case. - - elsif Normalized_First_Bit (Comp) /= Uint_0 - or else Esize (Comp) mod System_Storage_Unit /= Uint_0 - then - return True; - - -- If we are large and byte aligned, then OK at this level - -- but we still need to test our prefix recursively. - - else - return Possible_Bit_Aligned_Component (P); - end if; + return Possible_Bit_Aligned_Component (P); end if; end; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index cad54ac..fb73a0b 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -59,7 +59,6 @@ with Sem_Ch12; use Sem_Ch12; with Sem_Ch13; use Sem_Ch13; with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; -with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; @@ -2989,10 +2988,7 @@ package body Exp_Ch6 is Expression (Last (Pragma_Argument_Associations (TB_Pragma))); else Sec_Stack_Len := - Make_Integer_Literal (Loc, - Intval => - Expr_Value - (Constant_Value (RTE (RE_Default_Secondary_Stack_Size)))); + New_Occurrence_Of (RTE (RE_Default_Secondary_Stack_Size), Loc); end if; Sec_Stack_Len := Convert_To (RTE (RE_Storage_Offset), Sec_Stack_Len); @@ -3120,7 +3116,16 @@ package body Exp_Ch6 is -- If this is a Pure function which has any parameters whose root -- type is System.Address, reset the Pure indication, since it will - -- likely cause incorrect code to be generated. + -- likely cause incorrect code to be generated as the parameter is + -- probably a pointer, and the fact that the same pointer is passed + -- does not mean that the same value is being referenced. + + -- Note that if the programmer gave an explicit Pure_Function pragma, + -- then we believe the programmer, and leave the subprogram Pure. + + -- This code should probably be at the freeze point, so that it + -- happens even on a -gnatc (or more importantly -gnatt) compile + -- so that the semantic tree has Is_Pure set properly ??? if Is_Pure (Spec_Id) and then Is_Subprogram (Spec_Id) diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index e9e8053..7ec7918 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -508,7 +508,7 @@ package body Exp_Ch7 is return List_Id is Loc : constant Source_Ptr := Sloc (N); - Index_List : List_Id := New_List; + Index_List : constant List_Id := New_List; function Free_Component return List_Id; -- Generate the code to finalize the task or protected subcomponents @@ -524,7 +524,7 @@ package body Exp_Ch7 is function Free_Component return List_Id is Stmts : List_Id := New_List; Tsk : Node_Id; - C_Typ : Entity_Id := Component_Type (Typ); + C_Typ : constant Entity_Id := Component_Type (Typ); begin -- Component type is known to contain tasks or protected objects @@ -608,8 +608,8 @@ package body Exp_Ch7 is Loc : constant Source_Ptr := Sloc (N); Tsk : Node_Id; Comp : Entity_Id; - Stmts : List_Id := New_List; - U_Typ : constant Entity_Id := Underlying_Type (Typ); + Stmts : constant List_Id := New_List; + U_Typ : constant Entity_Id := Underlying_Type (Typ); begin if Has_Discriminants (U_Typ) @@ -696,13 +696,12 @@ package body Exp_Ch7 is ------------------------------------ procedure Clean_Simple_Protected_Objects (N : Node_Id) is + Stmts : constant List_Id := Statements (Handled_Statement_Sequence (N)); + Stmt : Node_Id := Last (Stmts); E : Entity_Id; - Stmts : List_Id := Statements (Handled_Statement_Sequence (N)); - Stmt : Node_Id := Last (Stmts); begin E := First_Entity (Current_Scope); - while Present (E) loop if (Ekind (E) = E_Variable or else Ekind (E) = E_Constant) diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index f8bf7f8..e77b3cd 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -8211,14 +8211,13 @@ package body Exp_Ch9 is and then Chars (Ritem) = Name_Attach_Handler then declare - Handler : constant Node_Id := - First (Pragma_Argument_Associations (Ritem)); - Interrupt : constant Node_Id := - Next (Handler); - Expr : Node_Id := Expression (Interrupt); + Handler : constant Node_Id := + First (Pragma_Argument_Associations (Ritem)); - begin + Interrupt : constant Node_Id := Next (Handler); + Expr : constant Node_Id := Expression (Interrupt); + begin Append_To (Table, Make_Aggregate (Loc, Expressions => New_List ( Unchecked_Convert_To diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 6c3911c..5ad0618 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -898,6 +898,52 @@ package body Exp_Util is return Build_Task_Image_Function (Loc, Decls, Stats, Res); end Build_Task_Record_Image; + ---------------------------------- + -- Component_May_Be_Bit_Aligned -- + ---------------------------------- + + function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is + begin + -- If no component clause, then everything is fine, since the + -- back end never bit-misaligns by default, even if there is + -- a pragma Packed for the record. + + if No (Component_Clause (Comp)) then + return False; + end if; + + -- It is only array and record types that cause trouble + + if not Is_Record_Type (Etype (Comp)) + and then not Is_Array_Type (Etype (Comp)) + then + return False; + + -- If we know that we have a small (64 bits or less) record + -- or bit-packed array, then everything is fine, since the + -- back end can handle these cases correctly. + + elsif Esize (Comp) <= 64 + and then (Is_Record_Type (Etype (Comp)) + or else Is_Bit_Packed_Array (Etype (Comp))) + then + return False; + + -- Otherwise if the component is not byte aligned, we + -- know we have the nasty unaligned case. + + elsif Normalized_First_Bit (Comp) /= Uint_0 + or else Esize (Comp) mod System_Storage_Unit /= Uint_0 + then + return True; + + -- If we are large and byte aligned, then OK at this level + + else + return False; + end if; + end Component_May_Be_Bit_Aligned; + ------------------------------- -- Convert_To_Actual_Subtype -- ------------------------------- @@ -3877,6 +3923,53 @@ package body Exp_Util is and then Esize (Left_Typ) = Esize (Result_Typ); end Target_Has_Fixed_Ops; + ------------------------------------------ + -- Type_May_Have_Bit_Aligned_Components -- + ------------------------------------------ + + function Type_May_Have_Bit_Aligned_Components + (Typ : Entity_Id) return Boolean + is + begin + -- Array type, check component type + + if Is_Array_Type (Typ) then + return + Type_May_Have_Bit_Aligned_Components (Component_Type (Typ)); + + -- Record type, check components + + elsif Is_Record_Type (Typ) then + declare + E : Entity_Id; + + begin + E := First_Entity (Typ); + while Present (E) loop + if Ekind (E) = E_Component + or else Ekind (E) = E_Discriminant + then + if Component_May_Be_Bit_Aligned (E) + or else + Type_May_Have_Bit_Aligned_Components (Etype (E)) + then + return True; + end if; + end if; + + Next_Entity (E); + end loop; + + return False; + end; + + -- Type other than array or record is always OK + + else + return False; + end if; + end Type_May_Have_Bit_Aligned_Components; + ---------------------------- -- Wrap_Cleanup_Procedure -- ---------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index e45930d..8dc14b7 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -208,6 +208,36 @@ package Exp_Util is -- computes the image without using concatenation, and one for the -- variable that holds the result. + function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean; + -- This function is in charge of detecting record components that may + -- cause trouble in the back end if an attempt is made to assign the + -- component. The back end can handle such assignments with no problem + -- if the components involved are small (64-bits or less) records or + -- scalar items (including bit-packed arrays represented with modular + -- types) or are both aligned on a byte boundary (starting on a byte + -- boundary, and occupying an integral number of bytes). + -- + -- However, problems arise for records larger than 64 bits, or for + -- arrays (other than bit-packed arrays represented with a modular + -- type) if the component starts on a non-byte boundary, or does + -- not occupy an integral number of bytes (i.e. there are some bits + -- possibly shared with fields at the start or beginning of the + -- component). The back end cannot handle loading and storing such + -- components in a single operation. + -- + -- This function is used to detect the troublesome situation. it is + -- conservative in the sense that it produces True unless it knows + -- for sure that the component is safe (as outlined in the first + -- paragraph above). The code generation for record and array + -- assignment checks for trouble using this function, and if so + -- the assignment is generated component-wise, which the back end + -- is required to handle correctly. + -- + -- Note that in GNAT 3, the back end will reject such components + -- anyway, so the hard work in checking for this case is wasted + -- in GNAT 3, but it's harmless, so it is easier to do it in + -- all cases, rather than conditionalize it in GNAT 5 or beyond. + procedure Convert_To_Actual_Subtype (Exp : Node_Id); -- The Etype of an expression is the nominal type of the expression, -- not the actual subtype. Often these are the same, but not always. @@ -512,6 +542,14 @@ package Exp_Util is -- operand and result types. This is called in package Exp_Fixd to -- determine whether to expand such operations. + function Type_May_Have_Bit_Aligned_Components + (Typ : Entity_Id) return Boolean; + -- Determines if Typ is a composite type that has within it (looking + -- down recursively at any subcomponents), a record type which has a + -- component that may be bit aligned (see Possible_Bit_Aligned_Component). + -- The result is conservative, in that a result of False is decisive. + -- A result of True means that such a component may or may not be present. + procedure Wrap_Cleanup_Procedure (N : Node_Id); -- Given an N_Subprogram_Body node, this procedure adds an Abort_Defer -- call at the start of the statement sequence, and an Abort_Undefer call diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index 181d58b..ecdcf19 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2003 Free Software Foundation, Inc. * + * Copyright (C) 1992-2004 Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -86,7 +86,7 @@ extern Node_Id Get_Attribute_Definition_Clause (Entity_Id, char); extern void Error_Msg_N (Fat_Pointer, Node_Id); extern void Error_Msg_NE (Fat_Pointer, Node_Id, Entity_Id); -extern void Set_Identifier_Casing (Char, Char); +extern void Set_Identifier_Casing (Char *, Char *); /* err_vars: */ @@ -98,7 +98,6 @@ extern Entity_Id Error_Msg_Node_2; extern Uint Error_Msg_Uint_1; extern Uint Error_Msg_Uint_2; - /* exp_code: */ #define Asm_Input_Constraint exp_code__asm_input_constraint @@ -169,6 +168,12 @@ extern void Check_No_Implicit_Heap_Alloc (Node_Id); extern void Check_Elaboration_Code_Allowed (Node_Id); extern void Check_No_Implicit_Heap_Alloc (Node_Id); +/* sem_elim: */ + +#define Eliminate_Error_Msg sem_elim__eliminate_error_msg + +extern void Eliminate_Error_Msg (Node_Id, Entity_Id); + /* sem_eval: */ #define Compile_Time_Known_Value sem_eval__compile_time_known_value diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 812ea69..5e135b7 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.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- -- @@ -2130,14 +2130,21 @@ package body Freeze is -- inherited the indication from elsewhere (e.g. an address -- clause, which is not good enough in RM terms!) - if Present (Get_Rep_Pragma (E, Name_Atomic)) or else - Present (Get_Rep_Pragma (E, Name_Atomic_Components)) or else - Present (Get_Rep_Pragma (E, Name_Volatile)) or else - Present (Get_Rep_Pragma (E, Name_Volatile_Components)) + if Present (Get_Rep_Pragma (E, Name_Atomic)) + or else + Present (Get_Rep_Pragma (E, Name_Atomic_Components)) then Error_Msg_N - ("stand alone atomic/volatile constant must be imported", - E); + ("stand alone atomic constant must be " & + "imported ('R'M 'C.6(13))", E); + + elsif Present (Get_Rep_Pragma (E, Name_Volatile)) + or else + Present (Get_Rep_Pragma (E, Name_Volatile_Components)) + then + Error_Msg_N + ("stand alone volatile constant must be " & + "imported ('R'M 'C.6(13))", E); end if; end if; @@ -4173,6 +4180,20 @@ package body Freeze is end if; end if; + -- Reset the Pure indication on an imported subprogram unless an + -- explicit Pure_Function pragma was present. We do this because + -- otherwise it is an insidious error to call a non-pure function + -- from a pure unit and have calls mysteriously optimized away. + -- What happens here is that the Import can bypass the normal + -- check to ensure that pure units call only pure subprograms. + + if Is_Imported (E) + and then Is_Pure (E) + and then not Has_Pragma_Pure_Function (E) + then + Set_Is_Pure (E, False); + end if; + -- For non-foreign convention subprograms, this is where we create -- the extra formals (for accessibility level and constrained bit -- information). We delay this till the freeze point precisely so diff --git a/gcc/ada/g-debuti.adb b/gcc/ada/g-debuti.adb index 8e4480a..627985c 100644 --- a/gcc/ada/g-debuti.adb +++ b/gcc/ada/g-debuti.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2003 Ada Core Technologies, Inc. -- +-- Copyright (C) 1997-2004 Ada Core Technologies, 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- -- @@ -153,7 +153,7 @@ package body GNAT.Debug_Utilities is -- Ada form based literal - elsif C = '#' or C = ':' then + elsif C = '#' or else C = ':' then Base := Res; Res := 0; diff --git a/gcc/ada/g-dirope.adb b/gcc/ada/g-dirope.adb index 321b812..40a181a 100644 --- a/gcc/ada/g-dirope.adb +++ b/gcc/ada/g-dirope.adb @@ -60,8 +60,7 @@ package body GNAT.Directory_Operations is function Base_Name (Path : Path_Name; - Suffix : String := "") - return String + Suffix : String := "") return String is function Get_File_Names_Case_Sensitive return Integer; pragma Import @@ -73,8 +72,7 @@ package body GNAT.Directory_Operations is function Basename (Path : Path_Name; - Suffix : String := "") - return String; + Suffix : String := "") return String; -- This function does the job. The only difference between Basename -- and Base_Name (the parent function) is that the former is case -- sensitive, while the latter is not. Path and Suffix are adjusted @@ -87,8 +85,7 @@ package body GNAT.Directory_Operations is function Basename (Path : Path_Name; - Suffix : String := "") - return String + Suffix : String := "") return String is Cut_Start : Natural := Strings.Fixed.Index @@ -227,8 +224,7 @@ package body GNAT.Directory_Operations is function Expand_Path (Path : Path_Name; - Mode : Environment_Style := System_Default) - return Path_Name + Mode : Environment_Style := System_Default) return Path_Name is Environment_Variable_Char : Character; pragma Import (C, Environment_Variable_Char, "__gnat_environment_char"); @@ -519,8 +515,7 @@ package body GNAT.Directory_Operations is function Format_Pathname (Path : Path_Name; - Style : Path_Style := System_Default) - return String + Style : Path_Style := System_Default) return String is N_Path : String := Path; K : Positive := N_Path'First; @@ -636,8 +631,7 @@ package body GNAT.Directory_Operations is C_File_Name : constant String := Dir_Name & ASCII.NUL; function opendir - (File_Name : String) - return Dir_Type_Value; + (File_Name : String) return Dir_Type_Value; pragma Import (C, opendir, "opendir"); begin @@ -668,8 +662,7 @@ package body GNAT.Directory_Operations is function readdir_gnat (Directory : System.Address; - Buffer : System.Address) - return System.Address; + Buffer : System.Address) return System.Address; pragma Import (C, readdir_gnat, "__gnat_readdir"); function strlen (S : Address) return Integer; diff --git a/gcc/ada/g-dirope.ads b/gcc/ada/g-dirope.ads index ae790de..c6c561d 100644 --- a/gcc/ada/g-dirope.ads +++ b/gcc/ada/g-dirope.ads @@ -122,8 +122,7 @@ package GNAT.Directory_Operations is function Base_Name (Path : Path_Name; - Suffix : String := "") - return String; + Suffix : String := "") return String; -- Any directory prefix is removed. If Suffix is non-empty and is a -- suffix of Path, it is removed. This is equivalent to the UNIX basename -- command. The following rule is always true: @@ -158,8 +157,7 @@ package GNAT.Directory_Operations is function Format_Pathname (Path : Path_Name; - Style : Path_Style := System_Default) - return Path_Name; + Style : Path_Style := System_Default) return Path_Name; -- Removes all double directory separator and converts all '\' to '/' if -- Style is UNIX and converts all '/' to '\' if Style is set to DOS. This -- function will help to provide a consistent naming scheme running for @@ -187,8 +185,7 @@ package GNAT.Directory_Operations is function Expand_Path (Path : Path_Name; - Mode : Environment_Style := System_Default) - return Path_Name; + Mode : Environment_Style := System_Default) return Path_Name; -- Returns Path with environment variables (or logical names on OpenVMS) -- replaced by the current environment variable value. For example, -- $HOME/mydir will be replaced by /home/joe/mydir if $HOME environment diff --git a/gcc/ada/g-sestin.ads b/gcc/ada/g-sestin.ads new file mode 100644 index 0000000..328436b --- /dev/null +++ b/gcc/ada/g-sestin.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- G N A T . S E C O N D A R Y _ S T A C K _ I N F O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004 Ada Core Technologies, 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- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides facilities for obtaining information on secondary +-- stack usage. + +with System.Secondary_Stack; + +package GNAT.Secondary_Stack_Info is + + function SS_Get_Max return Long_Long_Integer + renames System.Secondary_Stack.SS_Get_Max; + -- Return maximum used space in storage units for the current secondary + -- stack. For a dynamically allocated secondary stack, the returned + -- result is always -1. For a statically allocated secondary stack, + -- the returned value shows the largest amount of space allocated so + -- far during execution of the program to the current secondary stack, + -- i.e. the secondary stack for the current task. + +end GNAT.Secondary_Stack_Info; diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 6f9b8a0..f809c28 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.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- -- @@ -78,9 +78,6 @@ procedure Gnat1drv is Main_Unit_Node : Node_Id; -- Compilation unit node for main unit - Main_Unit_Entity : Node_Id; - -- Compilation unit entity for main unit - Main_Kind : Node_Kind; -- Kind of main compilation unit node. @@ -193,7 +190,7 @@ begin Write_Eol; Write_Str ("GNAT "); Write_Str (Gnat_Version_String); - Write_Str (" Copyright 1992-2003 Free Software Foundation, Inc."); + Write_Str (" Copyright 1992-2004 Free Software Foundation, Inc."); Write_Eol; end if; @@ -277,7 +274,6 @@ begin Original_Operating_Mode := Operating_Mode; Frontend; Main_Unit_Node := Cunit (Main_Unit); - Main_Unit_Entity := Cunit_Entity (Main_Unit); Main_Kind := Nkind (Unit (Main_Unit_Node)); -- Check for suspicious or incorrect body present if we are doing diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index d237863..c35c87e 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.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- -- @@ -379,7 +379,7 @@ begin Write_Eol; Write_Str ("GNATBIND "); Write_Str (Gnat_Version_String); - Write_Str (" Copyright 1995-2003 Free Software Foundation, Inc."); + Write_Str (" Copyright 1995-2004 Free Software Foundation, Inc."); Write_Eol; end if; diff --git a/gcc/ada/gnatchop.adb b/gcc/ada/gnatchop.adb index 7384cd3..509a6f3 100644 --- a/gcc/ada/gnatchop.adb +++ b/gcc/ada/gnatchop.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2003 Ada Core Technologies, Inc. -- +-- Copyright (C) 1998-2004 Ada Core Technologies, 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- -- @@ -375,7 +375,8 @@ procedure Gnatchop is if not Is_Duplicated (SNum) then declare - Info : Unit_Info := Unit.Table (Sorted_Units.Table (SNum)); + Info : constant Unit_Info := + Unit.Table (Sorted_Units.Table (SNum)); begin if Is_Writable_File (Info.File_Name.all) then @@ -587,10 +588,10 @@ procedure Gnatchop is ---------------- function Parse_File (Num : File_Num) return Boolean is - Chop_Name : constant String_Access := File.Table (Num).Name; + Chop_Name : constant String_Access := File.Table (Num).Name; + Save_Stdout : constant File_Descriptor := dup (Standout); Offset_Name : Temp_File_Name; Offset_FD : File_Descriptor; - Save_Stdout : File_Descriptor := dup (Standout); Buffer : String_Access; Success : Boolean; Failure : exception; @@ -690,9 +691,9 @@ procedure Gnatchop is (Chop_File : File_Num; Source : access String) is - First_Unit : Unit_Num := Unit.Last + 1; - Bufferg : String_Access := null; - Parse_Ptr : File_Offset := Source'First; + First_Unit : constant Unit_Num := Unit.Last + 1; + Bufferg : String_Access := null; + Parse_Ptr : File_Offset := Source'First; Token_Ptr : File_Offset; Info : Unit_Info; @@ -1147,7 +1148,7 @@ procedure Gnatchop is Put (Standard_Error, Gnatvsn.Gnat_Version_String); Put_Line (Standard_Error, - " Copyright 1998-2000, Ada Core Technologies Inc."); + " Copyright 1998-2004, Ada Core Technologies Inc."); when 'w' => Overwrite_Files := True; @@ -1736,7 +1737,7 @@ begin if Warning_Count > 0 then declare - Warnings_Msg : String := Warning_Count'Img & " warning(s)"; + Warnings_Msg : constant String := Warning_Count'Img & " warning(s)"; begin Error_Msg (Warnings_Msg (2 .. Warnings_Msg'Last), Warning => True); end; diff --git a/gcc/ada/gnatfind.adb b/gcc/ada/gnatfind.adb index 49fc1ed..c59ae49 100644 --- a/gcc/ada/gnatfind.adb +++ b/gcc/ada/gnatfind.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -24,10 +24,10 @@ -- -- ------------------------------------------------------------------------------ -with Xr_Tabls; use Xr_Tabls; -with Xref_Lib; use Xref_Lib; -with Osint; use Osint; -with Types; use Types; +with Xr_Tabls; use Xr_Tabls; +with Xref_Lib; use Xref_Lib; +with Osint; use Osint; +with Types; use Types; with Gnatvsn; with Opt; @@ -41,7 +41,6 @@ with GNAT.Strings; use GNAT.Strings; --------------- procedure Gnatfind is - Output_Ref : Boolean := False; Pattern : Xref_Lib.Search_Pattern; Local_Symbols : Boolean := True; @@ -240,7 +239,7 @@ procedure Gnatfind is procedure Write_Usage is begin Put_Line ("GNATFIND " & Gnatvsn.Gnat_Version_String - & " Copyright 1998-2003, Ada Core Technologies Inc."); + & " Copyright 1998-2004, Ada Core Technologies Inc."); Put_Line ("Usage: gnatfind pattern[:sourcefile[:line[:column]]] " & "[file1 file2 ...]"); New_Line; diff --git a/gcc/ada/gnatlbr.adb b/gcc/ada/gnatlbr.adb index 917f064..3dd2d4d 100644 --- a/gcc/ada/gnatlbr.adb +++ b/gcc/ada/gnatlbr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1997-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- -- @@ -77,10 +77,9 @@ begin exit when Next_Arg > Argument_Count; Process_One_Arg : declare - Arg : String := Argument (Next_Arg); + Arg : constant String := Argument (Next_Arg); begin - if Arg'Length > 9 and then Arg (1 .. 9) = "--create=" then if Mode = None then Mode := Create; @@ -192,28 +191,29 @@ begin -- Include_Dirs := 0; Include_Dir_Name := new String'(Include_Dir_Default_Prefix); - Get_Next_Dir_In_Path_Init (String_Access (Include_Dir_Name)); + Get_Next_Dir_In_Path_Init (Include_Dir_Name); loop declare - Dir : String_Access := String_Access - (Get_Next_Dir_In_Path (String_Access (Include_Dir_Name))); + Dir : constant String_Access := String_Access + (Get_Next_Dir_In_Path (Include_Dir_Name)); begin exit when Dir = null; Include_Dirs := Include_Dirs + 1; - Include_Dir (Include_Dirs) - := String_Access (Normalize_Directory_Name (Dir.all)); + Include_Dir (Include_Dirs) := + String_Access (Normalize_Directory_Name (Dir.all)); end; end loop; Object_Dirs := 0; Object_Dir_Name := new String'(Object_Dir_Default_Prefix); - Get_Next_Dir_In_Path_Init (String_Access (Object_Dir_Name)); + Get_Next_Dir_In_Path_Init (Object_Dir_Name); loop declare - Dir : String_Access := String_Access - (Get_Next_Dir_In_Path (String_Access (Object_Dir_Name))); + Dir : constant String_Access := + String_Access + (Get_Next_Dir_In_Path (Object_Dir_Name)); begin exit when Dir = null; Object_Dirs := Object_Dirs + 1; @@ -225,7 +225,6 @@ begin -- "Make" an alternate sublibrary for each default sublibrary. for Dirs in 1 .. Object_Dirs loop - Make_Args (1) := new String'("-C"); @@ -269,13 +268,14 @@ begin Make_Path := Locate_Exec_On_Path (Make); Put (Make); - for I in 1 .. Make_Args'Last loop + for J in 1 .. Make_Args'Last loop Put (" "); - Put (Make_Args (I).all); + Put (Make_Args (J).all); end loop; New_Line; Spawn (Make_Path.all, Make_Args, Success); + if not Success then Put_Line (Standard_Error, "Error: Make failed"); Exit_Program (E_Fatal); @@ -285,7 +285,7 @@ begin when Set => - -- Validate arguments. + -- Validate arguments if Lib_Dir = null then Put_Line (Standard_Error, @@ -311,7 +311,7 @@ begin Exit_Program (E_Fatal); end if; - -- Give instructions. + -- Give instructions Put_Line ("Copy the contents of " & ADC_File.all & " into your GNAT.ADC file"); @@ -332,7 +332,7 @@ begin when Delete => - -- Give instructions. + -- Give instructions Put_Line ("GNAT Librarian DELETE not yet implemented."); Put_Line ("Use appropriate system tools to remove library"); diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 5d198c0..c1b11ba 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2004 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -26,7 +26,6 @@ -- Gnatlink usage: please consult the gnat documentation -with Ada.Exceptions; use Ada.Exceptions; with ALI; use ALI; with Gnatvsn; use Gnatvsn; with Hostparm; @@ -40,6 +39,7 @@ with Table; with Types; with Ada.Command_Line; use Ada.Command_Line; +with Ada.Exceptions; use Ada.Exceptions; with GNAT.OS_Lib; use GNAT.OS_Lib; with Interfaces.C_Streams; use Interfaces.C_Streams; with System.CRTL; @@ -234,9 +234,10 @@ procedure Gnatlink is procedure Delete (Name : in String) is Status : int; - + pragma Unreferenced (Status); begin Status := unlink (Name'Address); + -- Is it really right to ignore an error here ??? end Delete; --------------- @@ -602,6 +603,9 @@ procedure Gnatlink is Nfirst : Integer; -- Current line slice (the slice does not contain line terminator) + Last : Integer; + -- Current line last character for shared libraries (without version) + Objs_Begin : Integer := 0; -- First object file index in Linker_Objects table @@ -986,20 +990,45 @@ procedure Gnatlink is elsif Next_Line (Nfirst .. Nlast) = "-ldecgnat" or else Next_Line (Nfirst .. Nlast) = "-lgnarl" or else Next_Line (Nfirst .. Nlast) = "-lgnat" + or else Next_Line + (1 .. Natural'Min (Nlast, 8 + Library_Version'Length)) = + Shared_Lib ("gnarl") + or else Next_Line + (1 .. Natural'Min (Nlast, 7 + Library_Version'Length)) = + Shared_Lib ("gnat") then + -- If it is a shared library, remove the library version. + -- We will be looking for the static version of the library + -- as it is in the same directory as the shared version. + + if Next_Line (Nlast - Library_Version'Length + 1 .. Nlast) + = Library_Version + then + -- Set Last to point to last character before the + -- library version. + + Last := Nlast - Library_Version'Length - 1; + else + Last := Nlast; + end if; + -- Given a Gnat standard library, search the -- library path to find the library location declare File_Path : String_Access; + Object_Lib_Extension : constant String := - Value (Object_Library_Ext_Ptr); + Value (Object_Library_Ext_Ptr); + File_Name : constant String := "lib" & - Next_Line (Nfirst + 2 .. Nlast) & - Object_Lib_Extension; + Next_Line (Nfirst + 2 .. Last) & + Object_Lib_Extension; + Run_Path_Opt : constant String := Value (Run_Path_Option_Ptr); - GCC_Index : Natural; + + GCC_Index : Natural; Run_Path_Opt_Index : Natural := 0; begin @@ -1189,7 +1218,7 @@ procedure Gnatlink is Write_Eol; Write_Str ("GNATLINK "); Write_Str (Gnat_Version_String); - Write_Str (" Copyright 1995-2003 Free Software Foundation, Inc"); + Write_Str (" Copyright 1995-2004 Free Software Foundation, Inc"); Write_Eol; end if; end Write_Header; @@ -1586,7 +1615,7 @@ begin -- Remove duplicate IDENTIFICATION directives (VMS) if Linker_Options.Table (J)'Length > 27 - and then Linker_Options.Table (J) (1 .. 27) + and then Linker_Options.Table (J) (1 .. 28) = "--for-linker=IDENTIFICATION=" then if IDENT_Op then diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb index efa5ed6..d1f8d9a 100644 --- a/gcc/ada/gnatls.adb +++ b/gcc/ada/gnatls.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- -- @@ -75,11 +75,8 @@ procedure Gnatls is Main_File : File_Name_Type; Ali_File : File_Name_Type; - - Text : Text_Buffer_Ptr; - Id : ALI_Id; - - Next_Arg : Positive; + Text : Text_Buffer_Ptr; + Next_Arg : Positive; Too_Long : Boolean := False; -- When True, lines are too long for multi-column output and each @@ -219,9 +216,8 @@ procedure Gnatls is ------------------------------ function Corresponding_Sdep_Entry - (A : ALI_Id; - U : Unit_Id) - return Sdep_Id + (A : ALI_Id; + U : Unit_Id) return Sdep_Id is begin for D in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop @@ -253,7 +249,6 @@ procedure Gnatls is -- Compute maximum of each column for Id in ALIs.First .. ALIs.Last loop - Get_Name_String (Units.Table (ALIs.Table (Id).First_Unit).Uname); if Also_Predef or else not Is_Internal_Unit then @@ -829,7 +824,6 @@ begin Scan_Args : while Next_Arg < Arg_Count loop declare Next_Argv : String (1 .. Len_Arg (Next_Arg)); - begin Fill_Arg (Next_Argv'Address, Next_Arg); Scan_Ls_Arg (Next_Argv, And_Save => True); @@ -866,7 +860,7 @@ begin Write_Eol; Write_Str ("GNATLS "); Write_Str (Gnat_Version_String); - Write_Str (" Copyright 1997-2003 Free Software Foundation, Inc."); + Write_Str (" Copyright 1997-2004 Free Software Foundation, Inc."); Write_Eol; Write_Eol; Write_Str ("Source Search Path:"); @@ -942,9 +936,16 @@ begin if Get_Name_Table_Info (Ali_File) = 0 then Text := Read_Library_Info (Ali_File, True); - Id := - Scan_ALI - (Ali_File, Text, Ignore_ED => False, Err => False); + + declare + Discard : ALI_Id; + pragma Unreferenced (Discard); + begin + Discard := + Scan_ALI + (Ali_File, Text, Ignore_ED => False, Err => False); + end; + Free (Text); end if; end if; @@ -1029,9 +1030,8 @@ begin end; end loop; - -- All done. Set proper exit status. + -- All done. Set proper exit status Namet.Finalize; Exit_Program (E_Success); - end Gnatls; diff --git a/gcc/ada/gnatmem.adb b/gcc/ada/gnatmem.adb index 8deca2e..21246b0 100644 --- a/gcc/ada/gnatmem.adb +++ b/gcc/ada/gnatmem.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2003, Ada Core Technologies, Inc. -- +-- Copyright (C) 1997-2004, Ada Core Technologies, 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- -- @@ -53,14 +53,18 @@ -- execution generating memory allocation where data is collected (such as -- number of allocations, amount of memory allocated, high water mark, etc.) -with GNAT.Command_Line; use GNAT.Command_Line; +with Gnatvsn; use Gnatvsn; + + with Ada.Text_IO; use Ada.Text_IO; with Ada.Float_Text_IO; with Ada.Integer_Text_IO; -with Gnatvsn; use Gnatvsn; + +with GNAT.Command_Line; use GNAT.Command_Line; with GNAT.Heap_Sort_G; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.HTable; use GNAT.HTable; + with System; use System; with System.Storage_Elements; use System.Storage_Elements; @@ -230,7 +234,7 @@ procedure Gnatmem is New_Line; Put ("GNATMEM "); Put (Gnat_Version_String); - Put_Line (" Copyright 1997-2003 Free Software Foundation, Inc."); + Put_Line (" Copyright 1997-2004 Free Software Foundation, Inc."); New_Line; Put_Line ("Usage: gnatmem switches [depth] exename"); @@ -287,20 +291,20 @@ procedure Gnatmem is when 's' => declare - S : String (Sort_Order'Range) := Parameter; + S : constant String (Sort_Order'Range) := Parameter; + begin for J in Sort_Order'Range loop - if S (J) = 'n' or else S (J) = 'w' - or else S (J) = 'h' then + if S (J) = 'n' or else + S (J) = 'w' or else + S (J) = 'h' + then Sort_Order (J) := S (J); else - raise Constraint_Error; + Put_Line ("Invalid sort criteria string."); + GNAT.OS_Lib.OS_Exit (1); end if; end loop; - exception - when Constraint_Error => - Put_Line ("Invalid sort criteria string."); - GNAT.OS_Lib.OS_Exit (1); end; when others => @@ -607,6 +611,8 @@ begin Result : Integer; + -- Start of processing for Lt + begin for S in Sort_Order'Range loop Result := Apply_Sort_Criterion (Sort_Order (S)); diff --git a/gcc/ada/gnatname.adb b/gcc/ada/gnatname.adb index 5a56728..fb35abb 100644 --- a/gcc/ada/gnatname.adb +++ b/gcc/ada/gnatname.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- -- @@ -66,7 +66,7 @@ procedure Gnatname is Table_Initial => 10, Table_Increment => 10, Table_Name => "Gnatname.Excluded_Patterns"); - -- Table to accumulate the negative patterns. + -- Table to accumulate the negative patterns package Foreign_Patterns is new Table.Table (Table_Component_Type => String_Access, @@ -75,7 +75,7 @@ procedure Gnatname is Table_Initial => 10, Table_Increment => 10, Table_Name => "Gnatname.Foreign_Patterns"); - -- Table to accumulate the foreign patterns. + -- Table to accumulate the foreign patterns package Patterns is new Table.Table (Table_Component_Type => String_Access, @@ -84,7 +84,7 @@ procedure Gnatname is Table_Initial => 10, Table_Increment => 10, Table_Name => "Gnatname.Patterns"); - -- Table to accumulate the name patterns. + -- Table to accumulate the name patterns package Source_Directories is new Table.Table (Table_Component_Type => String_Access, @@ -170,7 +170,7 @@ procedure Gnatname is Output.Write_Str ("GNATNAME "); Output.Write_Str (Gnatvsn.Gnat_Version_String); Output.Write_Line - (" Copyright 2001-2003 Free Software Foundation, Inc."); + (" Copyright 2001-2004 Free Software Foundation, Inc."); end if; end Output_Version; @@ -261,7 +261,6 @@ procedure Gnatname is exception when Invalid_Switch => Fail ("invalid switch " & Full_Switch); - end Scan_Args; ----------- diff --git a/gcc/ada/gnatsym.adb b/gcc/ada/gnatsym.adb index a15cb6d..6b1dd4d 100644 --- a/gcc/ada/gnatsym.adb +++ b/gcc/ada/gnatsym.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003 Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2004 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -55,7 +55,7 @@ with Table; procedure Gnatsym is Empty_String : aliased String := ""; - Empty : constant String_Access := Empty_String'Unchecked_Access; + Empty : constant String_Access := Empty_String'Unchecked_Access; -- To initialize variables Reference and Version_String Copyright_Displayed : Boolean := False; @@ -111,7 +111,7 @@ procedure Gnatsym is Write_Eol; Write_Str ("GNATSYMB "); Write_Str (Gnat_Version_String); - Write_Str (" Copyright 2003 Free Software Foundation, Inc"); + Write_Str (" Copyright 2003-2004 Free Software Foundation, Inc"); Write_Eol; Copyright_Displayed := True; end if; @@ -224,8 +224,7 @@ begin Write_Line (""""); end if; - -- Initialize the symbol file and, if specified, read the reference - -- file. + -- Initialize symbol file and, if specified, read reference file Symbols.Initialize (Symbol_File => Symbol_File_Name.all, diff --git a/gcc/ada/gnatxref.adb b/gcc/ada/gnatxref.adb index a7b22d6..d7b668d 100644 --- a/gcc/ada/gnatxref.adb +++ b/gcc/ada/gnatxref.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -72,7 +72,7 @@ procedure Gnatxref is when ASCII.NUL => exit; - when 'a' => + when 'a' => if GNAT.Command_Line.Full_Switch = "a" then Read_Only := True; @@ -83,49 +83,49 @@ procedure Gnatxref is Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter); end if; - when 'd' => + when 'd' => Der_Info := True; - when 'f' => + when 'f' => Full_Path_Name := True; - when 'g' => + when 'g' => Local_Symbols := False; - when 'h' => + when 'h' => Write_Usage; - when 'I' => + when 'I' => Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter); Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter); - when 'n' => + when 'n' => if GNAT.Command_Line.Full_Switch = "nostdinc" then Opt.No_Stdinc := True; elsif GNAT.Command_Line.Full_Switch = "nostlib" then Opt.No_Stdlib := True; end if; - when 'p' => + when 'p' => declare S : constant String := GNAT.Command_Line.Parameter; - begin Prj_File_Length := S'Length; Prj_File (1 .. Prj_File_Length) := S; end; - when 'u' => + when 'u' => Search_Unused := True; Vi_Mode := False; - when 'v' => + when 'v' => Vi_Mode := True; Search_Unused := False; -- The only switch starting with -- recognized is --RTS - when '-' => + when '-' => + -- Check that it is the first time we see this switch if RTS_Specified = null then @@ -210,7 +210,7 @@ procedure Gnatxref is procedure Write_Usage is begin Put_Line ("GNATXREF " & Gnatvsn.Gnat_Version_String - & " Copyright 1998-2003, Ada Core Technologies Inc."); + & " Copyright 1998-2004, Ada Core Technologies Inc."); Put_Line ("Usage: gnatxref [switches] file1 file2 ..."); New_Line; Put_Line (" file ... list of source files to xref, " & diff --git a/gcc/ada/gprcmd.adb b/gcc/ada/gprcmd.adb index 5718e12..9a033a2 100644 --- a/gcc/ada/gprcmd.adb +++ b/gcc/ada/gprcmd.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 2002-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- -- @@ -249,7 +249,7 @@ procedure Gprcmd is procedure Extend (Dir : String) is procedure Recursive_Extend (D : String); - -- Recursively display all subdirectories of D. + -- Recursively display all subdirectories of D ---------------------- -- Recursive_Extend -- @@ -355,7 +355,7 @@ begin Put (Standard_Error, "GPRCMD "); Put (Standard_Error, Gnatvsn.Gnat_Version_String); Put_Line (Standard_Error, - " Copyright 2002-2003, Free Software Fundation, Inc."); + " Copyright 2002-2004, Free Software Fundation, Inc."); Usage; elsif Cmd = "pwd" then @@ -437,8 +437,8 @@ begin Find_Program_Name; declare - Path : String_Access := - Locate_Exec_On_Path (Name_Buffer (1 .. Name_Len)); + Path : constant String_Access := + Locate_Exec_On_Path (Name_Buffer (1 .. Name_Len)); Index : Natural; begin @@ -454,7 +454,7 @@ begin and then Path (Index - 3 .. Index - 1) = "bin" and then Path (Index - 4) = Directory_Separator then - -- We have found the <prefix>, return it. + -- We have found the <prefix>, return it Put (Path (Path'First .. Index - 5)); end if; diff --git a/gcc/ada/gprep.adb b/gcc/ada/gprep.adb index 635d0df..015f964 100644 --- a/gcc/ada/gprep.adb +++ b/gcc/ada/gprep.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2003, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-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- -- @@ -24,8 +24,6 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Text_IO; use Ada.Text_IO; - with Csets; with Err_Vars; use Err_Vars; with Errutil; @@ -41,8 +39,9 @@ with Snames; with Stringt; use Stringt; with Types; use Types; +with Ada.Text_IO; use Ada.Text_IO; with GNAT.Command_Line; -with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.OS_Lib; use GNAT.OS_Lib; package body GPrep is @@ -57,11 +56,11 @@ package body GPrep is Outfile_Name : String_Access; Deffile_Name : String_Access; - Source_Ref_Pragma : Boolean := False; -- Set if -r switch set - -- Record command line options + Source_Ref_Pragma : Boolean := False; + -- Record command line options (set if -r switch set) Text_Outfile : aliased Ada.Text_IO.File_Type; - Outfile : File_Access := Text_Outfile'Access; + Outfile : constant File_Access := Text_Outfile'Access; ----------------- -- Subprograms -- @@ -87,11 +86,11 @@ package body GPrep is procedure Put_Char_To_Outfile (C : Character); -- Output one character to the output file. - -- Used to initialize the preprocessor.. + -- Used to initialize the preprocessor. procedure New_EOL_To_Outfile; -- Output a new line to the output file. - -- used to initialize the preprocessor. + -- Used to initialize the preprocessor. procedure Scan_Command_Line; -- Scan the switches and the file names @@ -108,7 +107,7 @@ package body GPrep is if not Copyright_Displayed then Write_Line ("GNAT Preprocessor " & Gnatvsn.Gnat_Version_String & - " Copyright 1996-2003 Free Software Foundation, Inc."); + " Copyright 1996-2004 Free Software Foundation, Inc."); Copyright_Displayed := True; end if; end Display_Copyright; diff --git a/gcc/ada/i-cstrea.adb b/gcc/ada/i-cstrea.adb index 2c85bc9..c133ddf 100644 --- a/gcc/ada/i-cstrea.adb +++ b/gcc/ada/i-cstrea.adb @@ -41,6 +41,31 @@ package body Interfaces.C_Streams is use type System.CRTL.size_t; + ---------------------------- + -- Interfaced C functions -- + ---------------------------- + + function C_fread + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) return size_t; + pragma Import (C, C_fread, "fread"); + + function C_fwrite + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) return size_t; + pragma Import (C, C_fwrite, "fwrite"); + + function C_setvbuf + (stream : FILEs; + buffer : chars; + mode : int; + size : size_t) return int; + pragma Import (C, C_setvbuf, "setvbuf"); + ------------ -- fread -- ------------ @@ -49,17 +74,8 @@ package body Interfaces.C_Streams is (buffer : voids; size : size_t; count : size_t; - stream : FILEs) - return size_t + stream : FILEs) return size_t is - function C_fread - (buffer : voids; - size : size_t; - count : size_t; - stream : FILEs) - return size_t; - pragma Import (C, C_fread, "fread"); - begin return C_fread (buffer, size, count, stream); end fread; @@ -68,31 +84,25 @@ package body Interfaces.C_Streams is -- fread -- ------------ + -- The following declarations should really be nested within fread, but + -- limitations in front end inlining make this undesirable right now ??? + + type Byte_Buffer is array (0 .. size_t'Last / 2 - 1) of Unsigned_8; + -- This should really be 0 .. size_t'last, but there is a problem + -- in gigi in handling such types (introduced in GCC 3 Sep 2001) + -- since the size in bytes of this array overflows ??? + + type Acc_Bytes is access all Byte_Buffer; + + function To_Acc_Bytes is new Unchecked_Conversion (voids, Acc_Bytes); + function fread (buffer : voids; index : size_t; size : size_t; count : size_t; - stream : FILEs) - return size_t + stream : FILEs) return size_t is - function C_fread - (buffer : voids; - size : size_t; - count : size_t; - stream : FILEs) - return size_t; - pragma Import (C, C_fread, "fread"); - - type Byte_Buffer is array (0 .. size_t'Last / 2 - 1) of Unsigned_8; - -- This should really be 0 .. size_t'last, but there is a problem - -- in gigi in handling such types (introduced in GCC 3 Sep 2001) - -- since the size in bytes of this array overflows ??? - - type Acc_Bytes is access all Byte_Buffer; - - function To_Acc_Bytes is new Unchecked_Conversion (voids, Acc_Bytes); - begin return C_fread (To_Acc_Bytes (buffer) (index * size)'Address, size, count, stream); @@ -106,17 +116,8 @@ package body Interfaces.C_Streams is (buffer : voids; size : size_t; count : size_t; - stream : FILEs) - return size_t + stream : FILEs) return size_t is - function C_fwrite - (buffer : voids; - size : size_t; - count : size_t; - stream : FILEs) - return size_t; - pragma Import (C, C_fwrite, "fwrite"); - begin return C_fwrite (buffer, size, count, stream); end fwrite; @@ -129,17 +130,8 @@ package body Interfaces.C_Streams is (stream : FILEs; buffer : chars; mode : int; - size : size_t) - return int + size : size_t) return int is - function C_setvbuf - (stream : FILEs; - buffer : chars; - mode : int; - size : size_t) - return int; - pragma Import (C, C_setvbuf, "setvbuf"); - begin return C_setvbuf (stream, buffer, mode, size); end setvbuf; diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index cec090f..b96da45 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -370,7 +370,7 @@ package body Inline is ---------------------------- function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean is - Decl : Node_Id := Unit_Declaration_Node (Subp); + Decl : constant Node_Id := Unit_Declaration_Node (Subp); Body_Ent : Entity_Id; Ent : Entity_Id; diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 055f53a..8314bd9 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -881,6 +881,10 @@ package body Lib.Writ is Write_Info_Str (" NS"); end if; + if Sec_Stack_Used then + Write_Info_Str (" SS"); + end if; + if Unreserve_All_Interrupts then Write_Info_Str (" UA"); end if; diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index ef640dc..977b4b3 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -176,6 +176,9 @@ package Lib.Writ is -- compiler, but is added by the Project Manager in gnatmake -- when an Interface ALI file is copied to the library -- directory. + + -- SS This unit references System.Secondary_Stack (that is, + -- the unit makes use of the secondary stack facilities). -- -- Tx A valid Task_Dispatching_Policy pragma applies to all -- the units in this file, where x is the first character diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 014a9e9..bc663a1 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -776,9 +776,8 @@ package body Lib.Xref is and then Ent = Base_Type (Ent) and then In_Extended_Main_Source_Unit (Ent) then - declare - Op_List : Elist_Id := Primitive_Operations (Ent); + Op_List : constant Elist_Id := Primitive_Operations (Ent); Op : Elmt_Id; Prim : Entity_Id; @@ -787,11 +786,10 @@ package body Lib.Xref is -- through several derivations. function Parent_Op (E : Entity_Id) return Entity_Id is - Orig_Op : Entity_Id := Alias (E); + Orig_Op : constant Entity_Id := Alias (E); begin if No (Orig_Op) then return Empty; - elsif not Comes_From_Source (E) and then not Has_Xref_Entry (Orig_Op) and then Comes_From_Source (Orig_Op) @@ -804,9 +802,7 @@ package body Lib.Xref is begin Op := First_Elmt (Op_List); - while Present (Op) loop - Prim := Parent_Op (Node (Op)); if Present (Prim) then diff --git a/gcc/ada/link.c b/gcc/ada/link.c index 4dd0876..c31db93 100644 --- a/gcc/ada/link.c +++ b/gcc/ada/link.c @@ -139,7 +139,7 @@ const char *object_library_extension = ".a"; #elif defined (VMS) const char *object_file_option = ""; const char *run_path_option = ""; -char shared_libgnat_default = SHARED; +char shared_libgnat_default = STATIC; int link_max = 2147483647; unsigned char objlist_file_supported = 0; unsigned char using_gnu_linker = 0; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index b566c6b..ed7c188 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.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- -- @@ -55,16 +55,17 @@ with Sinput.P; with Snames; use Snames; with Switch; use Switch; with Switch.M; use Switch.M; -with System.HTable; with Targparm; with Tempdir; -with Ada.Exceptions; use Ada.Exceptions; -with Ada.Command_Line; use Ada.Command_Line; +with Ada.Exceptions; use Ada.Exceptions; +with Ada.Command_Line; use Ada.Command_Line; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.Case_Util; use GNAT.Case_Util; +with System.HTable; + package body Make is use ASCII; @@ -3265,7 +3266,7 @@ package body Make is -------------------------- procedure Enter_Into_Obsoleted (F : Name_Id) is - Name : String := Get_Name_String (F); + Name : constant String := Get_Name_String (F); First : Natural := Name'Last; F2 : Name_Id := F; @@ -3398,7 +3399,55 @@ package body Make is Opt.Check_Object_Consistency := False; end if; - if Main_Project /= No_Project then + -- Special case when switch -B was specified + + if Build_Bind_And_Link_Full_Project then + + -- When switch -B is specified, there must be a project file + + if Main_Project = No_Project then + Make_Failed ("-B cannot be used without a project file"); + + -- No main program may be specified on the command line + + elsif Osint.Number_Of_Files /= 0 then + Make_Failed ("-B cannot be used with a main specified on " & + "the command line"); + + -- And the project file cannot be a library project file + + elsif Projects.Table (Main_Project).Library then + Make_Failed ("-B cannot be used for a library project file"); + + else + Insert_Project_Sources + (The_Project => Main_Project, + All_Projects => Unique_Compile_All_Projects, + Into_Q => False); + + -- If there are no sources to compile, we fail + + if Osint.Number_Of_Files = 0 then + Make_Failed ("no sources to compile"); + end if; + + -- Specify -n for gnatbind and add the ALI files of all the + -- sources, except the one which is a fake main subprogram: + -- this is the one for the binder generated file and it will be + -- transmitted to gnatlink. These sources are those that are + -- in the queue. + + Add_Switch ("-n", Binder, And_Save => True); + + for J in Q.First .. Q.Last - 1 loop + Add_Switch + (Get_Name_String + (Lib_File_Name (Q.Table (J).File)), + Binder, And_Save => True); + end loop; + end if; + + elsif Main_Project /= No_Project then -- If the main project file is a library project file, main(s) -- cannot be specified on the command line. @@ -3602,9 +3651,10 @@ package body Make is -- all the sources of the project. declare - Data : Project_Data := Projects.Table (Main_Project); + Data : constant Project_Data := + Projects.Table (Main_Project); - Languages : Variable_Value := + Languages : constant Variable_Value := Prj.Util.Value_Of (Name_Languages, Data.Decl.Attributes); @@ -3661,31 +3711,12 @@ package body Make is end loop; -- If we did not get any main, it means that all mains - -- in attribute Mains are in a foreign language. So, - -- we put all sources of the main project in the Q. + -- in attribute Mains are in a foreign language and -B + -- was not specified to gnatmake; so, we fail. if not At_Least_One_Main then - - -- First make sure that the binder and the linker - -- will not be invoked if -z is not used. - - if not No_Main_Subprogram then - Do_Bind_Step := False; - Do_Link_Step := False; - end if; - - -- Put all the sources in the queue - - Insert_Project_Sources - (The_Project => Main_Project, - All_Projects => Unique_Compile_All_Projects, - Into_Q => False); - - -- If there are no sources to compile, we fail - - if Osint.Number_Of_Files = 0 then - Make_Failed ("no sources to compile"); - end if; + Make_Failed + ("no Ada mains; use -B to build foreign main"); end if; end; @@ -3698,7 +3729,7 @@ package body Make is Write_Eol; Write_Str ("GNATMAKE "); Write_Str (Gnatvsn.Gnat_Version_String); - Write_Str (" Copyright 1995-2003 Free Software Foundation, Inc."); + Write_Str (" Copyright 1995-2004 Free Software Foundation, Inc."); Write_Eol; end if; @@ -4563,6 +4594,7 @@ package body Make is or not Do_Bind_Step or not Is_Main_Unit) and then not No_Main_Subprogram + and then not Build_Bind_And_Link_Full_Project then if Osint.Number_Of_Files = 1 then exit Multiple_Main_Loop; @@ -5995,7 +6027,7 @@ package body Make is else declare - Name : String := Get_Name_String (F); + Name : constant String := Get_Name_String (F); First : Natural := Name'Last; F2 : Name_Id := F; diff --git a/gcc/ada/makeusg.adb b/gcc/ada/makeusg.adb index 13ba0e5..73e91f1 100644 --- a/gcc/ada/makeusg.adb +++ b/gcc/ada/makeusg.adb @@ -61,6 +61,11 @@ begin Write_Str (" -b Bind only"); Write_Eol; + -- Line for -B + + Write_Str (" -B Build, bind and link full project"); + Write_Eol; + -- Line for -c Write_Str (" -c Compile only"); diff --git a/gcc/ada/mdll.adb b/gcc/ada/mdll.adb index 37dc55f..a6c9b23 100644 --- a/gcc/ada/mdll.adb +++ b/gcc/ada/mdll.adb @@ -59,12 +59,12 @@ package body MDLL is Base_Filename : constant String := MDLL.Fil.Ext_To (Lib_Filename); - Def_File : aliased String := Def_Filename; - Jnk_File : aliased String := Base_Filename & ".jnk"; - Bas_File : aliased String := Base_Filename & ".base"; - Dll_File : aliased String := Base_Filename & ".dll"; - Exp_File : aliased String := Base_Filename & ".exp"; - Lib_File : aliased String := "lib" & Base_Filename & ".a"; + Def_File : aliased constant String := Def_Filename; + Jnk_File : aliased String := Base_Filename & ".jnk"; + Bas_File : aliased constant String := Base_Filename & ".base"; + Dll_File : aliased String := Base_Filename & ".dll"; + Exp_File : aliased String := Base_Filename & ".exp"; + Lib_File : aliased constant String := "lib" & Base_Filename & ".a"; Bas_Opt : aliased String := "-Wl,--base-file," & Bas_File; Lib_Opt : aliased String := "-mdll"; @@ -187,10 +187,13 @@ package body MDLL is Utl.Gnatbind (L_Afiles, Options & Bargs_Options); declare - Params : OS_Lib.Argument_List := - Out_Opt'Unchecked_Access & Jnk_File'Unchecked_Access & - Lib_Opt'Unchecked_Access & - Bas_Opt'Unchecked_Access & Ofiles & All_Options; + Params : constant OS_Lib.Argument_List := + Out_Opt'Unchecked_Access & + Jnk_File'Unchecked_Access & + Lib_Opt'Unchecked_Access & + Bas_Opt'Unchecked_Access & + Ofiles & + All_Options; begin Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params); end; @@ -207,13 +210,14 @@ package body MDLL is Utl.Gnatbind (L_Afiles, Options & Bargs_Options); declare - Params : OS_Lib.Argument_List := - Out_Opt'Unchecked_Access & Jnk_File'Unchecked_Access & - Lib_Opt'Unchecked_Access & - Bas_Opt'Unchecked_Access & - Exp_File'Unchecked_Access & - Ofiles & - All_Options; + Params : constant OS_Lib.Argument_List := + Out_Opt'Unchecked_Access & + Jnk_File'Unchecked_Access & + Lib_Opt'Unchecked_Access & + Bas_Opt'Unchecked_Access & + Exp_File'Unchecked_Access & + Ofiles & + All_Options; begin Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params); end; @@ -230,13 +234,14 @@ package body MDLL is Utl.Gnatbind (L_Afiles, Options & Bargs_Options); declare - Params : OS_Lib.Argument_List := - Out_Opt'Unchecked_Access & Dll_File'Unchecked_Access & - Lib_Opt'Unchecked_Access & - Exp_File'Unchecked_Access & - Adr_Opt'Unchecked_Access & - Ofiles & - All_Options; + Params : constant OS_Lib.Argument_List := + Out_Opt'Unchecked_Access & + Dll_File'Unchecked_Access & + Lib_Opt'Unchecked_Access & + Exp_File'Unchecked_Access & + Adr_Opt'Unchecked_Access & + Ofiles & + All_Options; begin Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params); end; @@ -325,13 +330,14 @@ package body MDLL is Utl.Gnatbind (L_Afiles, Options & Bargs_Options); declare - Params : OS_Lib.Argument_List := - Out_Opt'Unchecked_Access & Dll_File'Unchecked_Access & - Lib_Opt'Unchecked_Access & - Exp_File'Unchecked_Access & - Adr_Opt'Unchecked_Access & - Ofiles & - All_Options; + Params : constant OS_Lib.Argument_List := + Out_Opt'Unchecked_Access & + Dll_File'Unchecked_Access & + Lib_Opt'Unchecked_Access & + Exp_File'Unchecked_Access & + Adr_Opt'Unchecked_Access & + Ofiles & + All_Options; begin Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params); end; diff --git a/gcc/ada/misc.c b/gcc/ada/misc.c index cd9663c..e9f2690 100644 --- a/gcc/ada/misc.c +++ b/gcc/ada/misc.c @@ -530,13 +530,19 @@ gnat_print_type (FILE *file, tree node, int indent) } static const char * -gnat_printable_name (tree decl, int verbosity ATTRIBUTE_UNUSED) +gnat_printable_name (tree decl, int verbosity) { const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl)); - char *ada_name = (char *) ggc_alloc (strlen (coded_name) * 2 + 60); + char *ada_name = (char *) ggc_alloc (strlen (coded_name) * 2 + 60); __gnat_decode (coded_name, ada_name, 0); + if (verbosity == 2) + { + Set_Identifier_Casing (ada_name, (char *) DECL_SOURCE_FILE (decl)); + ada_name = Name_Buffer; + } + return (const char *) ada_name; } diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index 9302558..19149c0 100644 --- a/gcc/ada/mlib-prj.adb +++ b/gcc/ada/mlib-prj.adb @@ -25,12 +25,14 @@ ------------------------------------------------------------------------------ with ALI; use ALI; +with Gnatvsn; use Gnatvsn; with Hostparm; with MLib.Fil; use MLib.Fil; with MLib.Tgt; use MLib.Tgt; with MLib.Utl; use MLib.Utl; with Namet; use Namet; with Opt; +with Osint; use Osint; with Output; use Output; with Prj.Com; use Prj.Com; with Prj.Env; use Prj.Env; @@ -1165,7 +1167,12 @@ package body MLib.Prj is if Libgnarl_Needed then Opts.Increment_Last; - Opts.Table (Opts.Last) := new String'("-lgnarl"); + + if The_Build_Mode = Static then + Opts.Table (Opts.Last) := new String'("-lgnarl"); + else + Opts.Table (Opts.Last) := new String'(Shared_Lib ("gnarl")); + end if; end if; if Libdecgnat_Needed then @@ -1177,7 +1184,12 @@ package body MLib.Prj is end if; Opts.Increment_Last; - Opts.Table (Opts.Last) := new String'("-lgnat"); + + if The_Build_Mode = Static then + Opts.Table (Opts.Last) := new String'("-lgnat"); + else + Opts.Table (Opts.Last) := new String'(Shared_Lib ("gnat")); + end if; -- If Path Option is supported, add the necessary switch with the -- content of Rpath. As Rpath contains at least libgnat directory @@ -1717,10 +1729,11 @@ package body MLib.Prj is -- For fopen Status : Interfaces.C_Streams.int; + pragma Unreferenced (Status); -- For fclose - Begin_Info : String := "-- BEGIN Object file/option list"; - End_Info : String := "-- END Object file/option list "; + Begin_Info : constant String := "-- BEGIN Object file/option list"; + End_Info : constant String := "-- END Object file/option list "; Next_Line : String (1 .. 1000); -- Current line value @@ -1793,18 +1806,30 @@ package body MLib.Prj is if Next_Line (1 .. Nlast) /= End_Info then loop - -- Disregard -static and -shared, as -shared will be used + -- Ignore -static and -shared, since -shared will be used -- in any case. - -- Disregard -lgnat, -lgnarl and -ldecgnat as they will be added + -- Ignore -lgnat, -lgnarl and -ldecgnat as they will be added -- later, because they are also needed for non Stand-Alone shared -- libraries. + -- Also ignore the shared libraries which are : + + -- UNIX / Windows VMS + -- -lgnat-<version> -lgnat_<version> (7 + version'length chars) + -- -lgnarl-<version> -lgnarl_<version> (8 + version'length chars) + if Next_Line (1 .. Nlast) /= "-static" and then Next_Line (1 .. Nlast) /= "-shared" and then Next_Line (1 .. Nlast) /= "-ldecgnat" and then Next_Line (1 .. Nlast) /= "-lgnarl" and then - Next_Line (1 .. Nlast) /= "-lgnat" + Next_Line (1 .. Nlast) /= "-lgnat" and then + Next_Line + (1 .. Natural'Min (Nlast, 8 + Library_Version'Length)) /= + Shared_Lib ("gnarl") and then + Next_Line + (1 .. Natural'Min (Nlast, 7 + Library_Version'Length)) /= + Shared_Lib ("gnat") then if Next_Line (1) /= '-' then @@ -1838,6 +1863,7 @@ package body MLib.Prj is end if; Status := fclose (Fd); + -- Is it really right to ignore any close error ??? end Process_Binder_File; ------------------ diff --git a/gcc/ada/mlib-tgt.adb b/gcc/ada/mlib-tgt.adb index d8e280a..6cebb5c 100644 --- a/gcc/ada/mlib-tgt.adb +++ b/gcc/ada/mlib-tgt.adb @@ -137,7 +137,6 @@ package body MLib.Tgt is function Is_Object_Ext (Ext : String) return Boolean is pragma Unreferenced (Ext); - begin return False; end Is_Object_Ext; @@ -148,7 +147,6 @@ package body MLib.Tgt is function Is_C_Ext (Ext : String) return Boolean is pragma Unreferenced (Ext); - begin return False; end Is_C_Ext; @@ -159,7 +157,6 @@ package body MLib.Tgt is function Is_Archive_Ext (Ext : String) return Boolean is pragma Unreferenced (Ext); - begin return False; end Is_Archive_Ext; @@ -179,7 +176,6 @@ package body MLib.Tgt is function Library_Exists_For (Project : Project_Id) return Boolean is pragma Unreferenced (Project); - begin return False; end Library_Exists_For; @@ -190,7 +186,6 @@ package body MLib.Tgt is function Library_File_Name_For (Project : Project_Id) return Name_Id is pragma Unreferenced (Project); - begin return No_Name; end Library_File_Name_For; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 356564a..6c6fb3e 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -165,6 +165,11 @@ package Opt is -- Force brief error messages to standard error, even if verbose mode is -- set (so that main error messages go to standard output). + Build_Bind_And_Link_Full_Project : Boolean := False; + -- GNATMAKE + -- Set to True to build, bind and link all the sources of a project file + -- (switch -B) + Check_Object_Consistency : Boolean := False; -- GNATBIND, GNATMAKE -- Set to True to check whether every object file is consistent with @@ -260,6 +265,13 @@ package Opt is -- of the original source code. Causes debugging information to be -- written with respect to the generated code file that is written. + Default_Sec_Stack_Size : Int := -1; + -- GNATBIND + -- Set to default secondary stack size in units of kilobytes. Set by + -- the -Dnnn switch for the binder. A value of -1 indicates that no + -- default was set by the binder, and that the default should be the + -- initial value of System.Secondary_Stack.Default_Secondary_Stack_Size. + Display_Compilation_Progress : Boolean := False; -- GNATMAKE -- Set True (-d switch) to display information on progress while compiling @@ -767,6 +779,11 @@ package Opt is -- GNATMAKE, GNATLINK -- Set to False when no run_path_option should be issued to the linker + Sec_Stack_Used : Boolean := False; + -- GNAT, GBATBIND + -- Set True if generated code uses the System.Secondary_Stack package. + -- For the binder, set if any unit uses the secondary stack package. + Shared_Libgnat : Boolean; -- GNATBIND -- Set to True if a shared libgnat is requested by using the -shared diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 1bd39c4..ac2a527 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -24,15 +24,17 @@ -- -- ------------------------------------------------------------------------------ -with Fmap; use Fmap; +with Fmap; use Fmap; +with Gnatvsn; use Gnatvsn; with Hostparm; -with Namet; use Namet; -with Opt; use Opt; -with Output; use Output; -with Sdefault; use Sdefault; -with System.Case_Util; use System.Case_Util; +with Namet; use Namet; +with Opt; use Opt; +with Output; use Output; +with Sdefault; use Sdefault; with Table; +with System.Case_Util; use System.Case_Util; + with Unchecked_Conversion; with GNAT.OS_Lib; use GNAT.OS_Lib; @@ -610,7 +612,6 @@ package body Osint is function C_String_Length (S : Address) return Integer is function Strlen (S : Address) return Integer; pragma Import (C, Strlen, "strlen"); - begin if S = Null_Address then return 0; @@ -646,7 +647,6 @@ package body Osint is function Concat (String_One : String; String_Two : String) return String is Buffer : String (1 .. String_One'Length + String_Two'Length); - begin Buffer (1 .. String_One'Length) := String_One; Buffer (String_One'Length + 1 .. Buffer'Last) := String_Two; @@ -814,13 +814,14 @@ package body Osint is procedure Exit_Program (Exit_Code : Exit_Code_Type) is begin -- The program will exit with the following status: + -- 0 if the object file has been generated (with or without warnings) -- 1 if recompilation was not needed (smart recompilation) -- 2 if gnat1 has been killed by a signal (detected by GCC) -- 4 for a fatal error -- 5 if there were errors -- 6 if no code has been generated (spec) - -- + -- Note that exit code 3 is not used and must not be used as this is -- the code returned by a program aborted via C abort() routine on -- Windows. GCC checks for that case and thinks that the child process @@ -1205,9 +1206,9 @@ package body Osint is return null; end if; - else - -- Search in the current directory + -- Search in the current directory + else -- Get the current directory declare @@ -1845,7 +1846,7 @@ package body Osint is -- Start of processing for Read_Default_Search_Dirs begin - -- Construct a C compatible character string buffer. + -- Construct a C compatible character string buffer Buffer (1 .. Search_Dir_Prefix.all'Length) := Search_Dir_Prefix.all; @@ -1940,7 +1941,7 @@ package body Osint is -- indicates failure to open the specified source file. Text : Text_Buffer_Ptr; - -- Allocated text buffer. + -- Allocated text buffer Status : Boolean; -- For the calls to Close @@ -2001,23 +2002,7 @@ package body Osint is else Current_Full_Obj_Stamp := Empty_Time_Stamp; Close (Lib_FD, Status); - -- No need to check the status, we return null anyway - return null; - end if; - end if; - - -- Object file exists, compare object and ALI time stamps - - if Current_Full_Lib_Stamp > Current_Full_Obj_Stamp then - if Fatal_Err then - Get_Name_String (Current_Full_Obj_Name); - Close (Lib_FD, Status); - -- No need to check the status, we fail anyway - Fail ("Bad time stamp: ", Name_Buffer (1 .. Name_Len)); - else - Current_Full_Obj_Stamp := Empty_Time_Stamp; - Close (Lib_FD, Status); -- No need to check the status, we return null anyway return null; @@ -2183,6 +2168,7 @@ package body Osint is -- Read is complete, get time stamp and close file and we are done Close (Source_File_FD, Status); + -- The status should never be False. But, if it is, what can we do? -- So, we don't test it. @@ -2206,6 +2192,7 @@ package body Osint is Std_Prefix := Executable_Prefix; if Std_Prefix.all /= "" then + -- Remove trailing directory separator when calling set_std_prefix set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1); @@ -2240,6 +2227,31 @@ package body Osint is Running_Program := P; end Set_Program; + ---------------- + -- Shared_Lib -- + ---------------- + + function Shared_Lib (Name : String) return String is + Library : String (1 .. Name'Length + Library_Version'Length + 3); + -- 3 = 2 for "-l" + 1 for "-" before lib version + + begin + Library (1 .. 2) := "-l"; + Library (3 .. 2 + Name'Length) := Name; + Library (3 + Name'Length) := '-'; + Library (4 + Name'Length .. Library'Last) := Library_Version; + + if Hostparm.OpenVMS then + for K in Library'First + 2 .. Library'Last loop + if Library (K) = '.' or else Library (K) = '-' then + Library (K) := '_'; + end if; + end loop; + end if; + + return Library; + end Shared_Lib; + ---------------------- -- Smart_File_Stamp -- ---------------------- @@ -2317,9 +2329,11 @@ package body Osint is Get_Name_String (Name); for J in reverse 1 .. Name_Len - 1 loop + -- If we find the last directory separator if Is_Directory_Separator (Name_Buffer (J)) then + -- Return the part of Name that follows this last directory -- separator. @@ -2344,8 +2358,7 @@ package body Osint is for J in reverse 2 .. Name_Len loop - -- If we found the last '.', return the part of Name that precedes - -- this '.'. + -- If we found the last '.', return part of Name that precedes it if Name_Buffer (J) = '.' then Name_Len := J - 1; @@ -2595,7 +2608,7 @@ package body Osint is Path_Len : Integer) return String_Access is subtype Path_String is String (1 .. Path_Len); - type Path_String_Access is access Path_String; + type Path_String_Access is access Path_String; function Address_To_Access is new Unchecked_Conversion (Source => Address, @@ -2604,7 +2617,7 @@ package body Osint is Path_Access : constant Path_String_Access := Address_To_Access (Path_Addr); - Return_Val : String_Access; + Return_Val : String_Access; begin Return_Val := new String (1 .. Path_Len); @@ -2669,7 +2682,6 @@ package body Osint is Name_Buffer (1 .. Name_Len); begin - Find_Program_Name; -- Convert the name to lower case so error messages are the same on diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads index 18e2610..a1c37be 100644 --- a/gcc/ada/osint.ads +++ b/gcc/ada/osint.ads @@ -213,6 +213,12 @@ package Osint is -- If the above computation fails, return Path. -- This function assumes that Prefix'First = Path'First + function Shared_Lib (Name : String) return String; + -- Returns the runtime shared library in the form -l<name>-<version> where + -- version is the GNAT runtime library option for the platform. For example + -- this routine called with Name set to "gnat" will return "-lgnat-5.02" + -- on UNIX and Windows and -lgnat_5_02 on VMS. + ------------------------- -- Search Dir Routines -- ------------------------- diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 6089bea..3f32502 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -125,8 +125,7 @@ package body Prj.Nmsc is function Is_Illegal_Suffix (Suffix : String; - Dot_Replacement_Is_A_Single_Dot : Boolean) - return Boolean; + Dot_Replacement_Is_A_Single_Dot : Boolean) return Boolean; -- Returns True if the string Suffix cannot be used as -- a spec suffix, a body suffix or a separate suffix. @@ -154,15 +153,13 @@ package body Prj.Nmsc is function Path_Name_Of (File_Name : Name_Id; - Directory : Name_Id) - return String; + Directory : Name_Id) return String; -- Returns the path name of a (non project) file. -- Returns an empty string if file cannot be found. function Project_Extends (Extending : Project_Id; - Extended : Project_Id) - return Boolean; + Extended : Project_Id) return Boolean; -- Returns True if Extending is extending directly or indirectly Extended. procedure Check_Naming_Scheme @@ -2522,8 +2519,7 @@ package body Prj.Nmsc is function Is_Illegal_Suffix (Suffix : String; - Dot_Replacement_Is_A_Single_Dot : Boolean) - return Boolean + Dot_Replacement_Is_A_Single_Dot : Boolean) return Boolean is begin if Suffix'Length = 0 or else Index (Suffix, ".") = 0 then @@ -2574,14 +2570,16 @@ package body Prj.Nmsc is ---------------------- procedure Find_Source_Dirs (From : Name_Id; Location : Source_Ptr) is - Directory : constant String := Get_Name_String (From); + Directory : constant String := Get_Name_String (From); + Element : String_Element; + Canonical_Directory_Id : Name_Id; - Element : String_Element; + pragma Unreferenced (Canonical_Directory_Id); + -- Is this in fact being used for anything useful ??? procedure Recursive_Find_Dirs (Path : Name_Id); - -- Find all the subdirectories (recursively) of Path - -- and add them to the list of source directories - -- of the project. + -- Find all the subdirectories (recursively) of Path and add them + -- to the list of source directories of the project. ------------------------- -- Recursive_Find_Dirs -- @@ -2602,12 +2600,14 @@ package body Prj.Nmsc is Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); declare - The_Path : String := + The_Path : constant String := Normalize_Pathname (Name => Name_Buffer (1 .. Name_Len)) & - Directory_Separator; + Directory_Separator; + The_Path_Last : constant Natural := Compute_Directory_Last (The_Path); + begin Name_Len := The_Path_Last - The_Path'First + 1; Name_Buffer (1 .. Name_Len) := @@ -2738,8 +2738,13 @@ package body Prj.Nmsc is Get_Name_String (From); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + -- Directory := Name_Buffer (1 .. Name_Len); + -- Why is above line commented out ??? + Canonical_Directory_Id := Name_Find; + -- What is purpose of above assignment ??? + -- Are we sure it is being used ??? if Current_Verbosity = High then Write_Str (Directory); @@ -3609,8 +3614,7 @@ package body Prj.Nmsc is function Path_Name_Of (File_Name : Name_Id; - Directory : Name_Id) - return String + Directory : Name_Id) return String is Result : String_Access; The_Directory : constant String := Get_Name_String (Directory); @@ -3635,8 +3639,7 @@ package body Prj.Nmsc is function Project_Extends (Extending : Project_Id; - Extended : Project_Id) - return Boolean + Extended : Project_Id) return Boolean is Current : Project_Id := Extending; begin diff --git a/gcc/ada/prj-pp.adb b/gcc/ada/prj-pp.adb index 1ac45ed..965939d 100644 --- a/gcc/ada/prj-pp.adb +++ b/gcc/ada/prj-pp.adb @@ -254,7 +254,8 @@ package body Prj.PP is ------------------------------- procedure Write_End_Of_Line_Comment (Node : Project_Node_Id) is - Value : Name_Id := End_Of_Line_Comment (Node); + Value : constant Name_Id := End_Of_Line_Comment (Node); + begin if Value /= No_Name then Write_String (" --"); diff --git a/gcc/ada/prj-util.adb b/gcc/ada/prj-util.adb index e112000..15f893a 100644 --- a/gcc/ada/prj-util.adb +++ b/gcc/ada/prj-util.adb @@ -92,7 +92,7 @@ package body Prj.Util is Attribute_Or_Array_Name => Name_Executable, In_Package => Builder_Package); - Executable_Suffix : Variable_Value := + Executable_Suffix : constant Variable_Value := Prj.Util.Value_Of (Name => Main, Attribute_Or_Array_Name => @@ -118,7 +118,8 @@ package body Prj.Util is -- the specification suffix. declare - Name : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); + Name : constant String (1 .. Name_Len) := + Name_Buffer (1 .. Name_Len); Last : Positive := Name_Len; Naming : constant Naming_Data := diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 3d0acf1..c0249de 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -441,6 +441,7 @@ package body Rtsfind is if S /= "not found" or else not Configurable_Run_Time_Mode + or else All_Errors_Mode then M (1 .. 6) := "\file "; P := 6; @@ -541,6 +542,12 @@ package body Rtsfind is return; end if; + -- Note if secondary stack is used + + if U_Id = System_Secondary_Stack then + Opt.Sec_Stack_Used := True; + end if; + -- Otherwise we need to load the unit, First build unit name -- from the enumeration literal name in type RTU_Id. diff --git a/gcc/ada/s-interr.adb b/gcc/ada/s-interr.adb index 0145610..f62bfc5 100644 --- a/gcc/ada/s-interr.adb +++ b/gcc/ada/s-interr.adb @@ -346,8 +346,7 @@ package body System.Interrupts is --------------------- function Current_Handler - (Interrupt : Interrupt_ID) - return Parameterless_Handler + (Interrupt : Interrupt_ID) return Parameterless_Handler is begin if Is_Reserved (Interrupt) then @@ -455,21 +454,17 @@ package body System.Interrupts is -- Need comments as to why these always return True function Has_Interrupt_Or_Attach_Handler - (Object : access Dynamic_Interrupt_Protection) - return Boolean + (Object : access Dynamic_Interrupt_Protection) return Boolean is pragma Unreferenced (Object); - begin return True; end Has_Interrupt_Or_Attach_Handler; function Has_Interrupt_Or_Attach_Handler - (Object : access Static_Interrupt_Protection) - return Boolean + (Object : access Static_Interrupt_Protection) return Boolean is pragma Unreferenced (Object); - begin return True; end Has_Interrupt_Or_Attach_Handler; @@ -686,8 +681,7 @@ package body System.Interrupts is ------------------ function Unblocked_By - (Interrupt : Interrupt_ID) - return System.Tasking.Task_ID + (Interrupt : Interrupt_ID) return System.Tasking.Task_ID is begin if Is_Reserved (Interrupt) then diff --git a/gcc/ada/s-poosiz.adb b/gcc/ada/s-poosiz.adb index 54db132..37878cf 100644 --- a/gcc/ada/s-poosiz.adb +++ b/gcc/ada/s-poosiz.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2003 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- -- @@ -32,6 +32,7 @@ ------------------------------------------------------------------------------ with System.Storage_Elements; +with System.Soft_Links; with Unchecked_Conversion; @@ -40,6 +41,16 @@ package body System.Pool_Size is package SSE renames System.Storage_Elements; use type SSE.Storage_Offset; + -- Even though these storage pools are typically only used + -- by a single task, if multiple tasks are declared at the + -- same or a more nested scope as the storage pool, there + -- still may be concurrent access. The current implementation + -- of Stack_Bounded_Pool always uses a global lock for protecting + -- access. This should eventually be replaced by an atomic + -- linked list implementation for efficiency reasons. + + package SSL renames System.Soft_Links; + type Storage_Count_Access is access SSE.Storage_Count; function To_Storage_Count_Access is new Unchecked_Conversion (Address, Storage_Count_Access); @@ -82,6 +93,8 @@ package body System.Pool_Size is Alignment : SSE.Storage_Count) is begin + SSL.Lock_Task.all; + if Pool.Elmt_Size = 0 then Vsize.Allocate (Pool, Address, Storage_Size, Alignment); @@ -98,6 +111,13 @@ package body System.Pool_Size is else raise Storage_Error; end if; + + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; end Allocate; ---------------- @@ -111,6 +131,8 @@ package body System.Pool_Size is Alignment : SSE.Storage_Count) is begin + SSL.Lock_Task.all; + if Pool.Elmt_Size = 0 then Vsize.Deallocate (Pool, Address, Storage_Size, Alignment); @@ -118,6 +140,12 @@ package body System.Pool_Size is To_Storage_Count_Access (Address).all := Pool.First_Free; Pool.First_Free := Address - Pool.The_Pool'Address + 1; end if; + + SSL.Unlock_Task.all; + exception + when others => + SSL.Unlock_Task.all; + raise; end Deallocate; ---------------- diff --git a/gcc/ada/s-secsta.adb b/gcc/ada/s-secsta.adb index ecb5e9e..449d986 100644 --- a/gcc/ada/s-secsta.adb +++ b/gcc/ada/s-secsta.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -45,6 +45,27 @@ package body System.Secondary_Stack is SS_Ratio_Dynamic : constant Boolean := Parameters.Sec_Stack_Ratio = Parameters.Dynamic; + -- There are two entirely different implementations of the secondary + -- stack mechanism in this unit, and this Boolean is used to select + -- between them (at compile time, so the generated code will contain + -- only the code for the desired variant). If SS_Ratio_Dynamic is + -- True, then the secondary stack is dynamically allocated from the + -- heap in a linked list of chunks. If SS_Ration_Dynamic is False, + -- then the secondary stack is allocated statically by grabbing a + -- section of the primary stack and using it for this purpose. + + type Memory is array (Mark_Id range <>) of SSE.Storage_Element; + for Memory'Alignment use Standard'Maximum_Alignment; + -- This is the type used for actual allocation of secondary stack + -- areas. We require maximum alignment for all such allocations. + + --------------------------------------------------------------- + -- Data Structures for Dynamically Allocated Secondary Stack -- + --------------------------------------------------------------- + + -- The following is a diagram of the data structures used for the + -- case of a dynamically allocated secondary stack, where the stack + -- is allocated as a linked list of chunks allocated from the heap. -- +------------------+ -- | Next | @@ -76,8 +97,6 @@ package body System.Secondary_Stack is -- | Default_Size | | Prev | -- +-----------------+ +------------------+ -- - -- - type Memory is array (Mark_Id range <>) of SSE.Storage_Element; type Chunk_Id (First, Last : Mark_Id); type Chunk_Ptr is access all Chunk_Id; @@ -93,198 +112,302 @@ package body System.Secondary_Stack is Current_Chunk : Chunk_Ptr; end record; + type Stack_Ptr is access Stack_Id; + -- Pointer to record used to represent a dynamically allocated secondary + -- stack descriptor for a secondary stack chunk. + + procedure Free is new Unchecked_Deallocation (Chunk_Id, Chunk_Ptr); + -- Free a dynamically allocated chunk + + function To_Stack_Ptr is new + Unchecked_Conversion (Address, Stack_Ptr); + function To_Addr is new + Unchecked_Conversion (Stack_Ptr, Address); + -- Convert to and from address stored in task data structures + + -------------------------------------------------------------- + -- Data Structures for Statically Allocated Secondary Stack -- + -------------------------------------------------------------- + + -- For the static case, the secondary stack is a single contiguous + -- chunk of storage, carved out of the primary stack, and represented + -- by the following data strcuture + type Fixed_Stack_Id is record - Top : Mark_Id; + Top : Mark_Id; + -- Index of next available location in Mem. This is initialized to + -- 0, and then incremented on Allocate, and Decremented on Release. + Last : Mark_Id; - Mem : Memory (1 .. Mark_Id'Last / 2 - 1); - -- This should really be 1 .. Mark_Id'Last, but there is a bug in gigi - -- with this type, introduced Sep 2001, that causes gigi to reject this - -- type because its size in bytes overflows ??? + -- Length of usable Mem array, which is thus the index past the + -- last available location in Mem. Mem (Last-1) can be used. This + -- is used to check that the stack does not overflow. + + Max : Mark_Id; + -- Maximum value of Top. Initialized to 0, and then may be incremented + -- on Allocate, but is never Decremented. The last used location will + -- be Mem (Max - 1), so Max is the maximum count of used stack space. + + Mem : Memory (0 .. 0); + -- This is the area that is actually used for the secondary stack. + -- Note that the upper bound is a dummy value properly defined by + -- the value of Last. We never actually allocate objects of type + -- Fixed_Stack_Id, so the bounds declared here do not matter. end record; - type Stack_Ptr is access Stack_Id; - type Fixed_Stack_Ptr is access Fixed_Stack_Id; + Dummy_Fixed_Stack : Fixed_Stack_Id; + pragma Warnings (Off, Dummy_Fixed_Stack); + -- Well it is not quite true that we never allocate an object of the + -- type. This dummy object is allocated for the purpose of getting the + -- offset of the Mem field via the 'Position attribute (such a nuisance + -- that we cannot apply this to a field of a type!) - function From_Addr is new Unchecked_Conversion (Address, Stack_Ptr); - function To_Addr is new Unchecked_Conversion (Stack_Ptr, System.Address); - function To_Fixed is new Unchecked_Conversion (Stack_Ptr, Fixed_Stack_Ptr); + type Fixed_Stack_Ptr is access Fixed_Stack_Id; + -- Pointer to record used to describe statically allocated sec stack - procedure Free is new Unchecked_Deallocation (Chunk_Id, Chunk_Ptr); + function To_Fixed_Stack_Ptr is new + Unchecked_Conversion (Address, Fixed_Stack_Ptr); + -- Convert from address stored in task data structures -------------- -- Allocate -- -------------- procedure SS_Allocate - (Address : out System.Address; + (Addr : out Address; Storage_Size : SSE.Storage_Count) is - Stack : constant Stack_Ptr := - From_Addr (SSL.Get_Sec_Stack_Addr.all); - Fixed_Stack : Fixed_Stack_Ptr; - Chunk : Chunk_Ptr; Max_Align : constant Mark_Id := Mark_Id (Standard'Maximum_Alignment); Max_Size : constant Mark_Id := ((Mark_Id (Storage_Size) + Max_Align - 1) / Max_Align) * Max_Align; - To_Be_Released_Chunk : Chunk_Ptr; - begin - -- If the secondary stack is fixed in the primary stack, then the - -- handling becomes simple + -- Case of fixed allocation secondary stack if not SS_Ratio_Dynamic then - Fixed_Stack := To_Fixed (Stack); + declare + Fixed_Stack : constant Fixed_Stack_Ptr := + To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); - if Fixed_Stack.Top + Max_Size > Fixed_Stack.Last then - raise Storage_Error; - end if; + begin + -- Check if max stack usage is increasing - Address := Fixed_Stack.Mem (Fixed_Stack.Top)'Address; - Fixed_Stack.Top := Fixed_Stack.Top + Mark_Id (Max_Size); - return; - end if; + if Fixed_Stack.Top + Max_Size > Fixed_Stack.Max then + + -- If so, check if max size is exceeded + + if Fixed_Stack.Top + Max_Size > Fixed_Stack.Last then + raise Storage_Error; + end if; + + -- Record new max usage + + Fixed_Stack.Max := Fixed_Stack.Top + Max_Size; + end if; + + -- Set resulting address and update top of stack pointer - Chunk := Stack.Current_Chunk; + Addr := Fixed_Stack.Mem (Fixed_Stack.Top)'Address; + Fixed_Stack.Top := Fixed_Stack.Top + Max_Size; + end; - -- The Current_Chunk may not be the good one if a lot of release - -- operations have taken place. So go down the stack if necessary + -- Case of dynamically allocated secondary stack - while Chunk.First > Stack.Top loop - Chunk := Chunk.Prev; - end loop; + else + declare + Stack : constant Stack_Ptr := + To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); + Chunk : Chunk_Ptr; - -- Find out if the available memory in the current chunk is sufficient. - -- if not, go to the next one and eventally create the necessary room + To_Be_Released_Chunk : Chunk_Ptr; - while Chunk.Last - Stack.Top + 1 < Max_Size loop - if Chunk.Next /= null then + begin + Chunk := Stack.Current_Chunk; - -- Release unused non-first empty chunk + -- The Current_Chunk may not be the good one if a lot of release + -- operations have taken place. So go down the stack if necessary - if Chunk.Prev /= null and then Chunk.First = Stack.Top then - To_Be_Released_Chunk := Chunk; + while Chunk.First > Stack.Top loop Chunk := Chunk.Prev; - Chunk.Next := To_Be_Released_Chunk.Next; - To_Be_Released_Chunk.Next.Prev := Chunk; - Free (To_Be_Released_Chunk); - end if; + end loop; + + -- Find out if the available memory in the current chunk is + -- sufficient, if not, go to the next one and eventally create + -- the necessary room. + + while Chunk.Last - Stack.Top + 1 < Max_Size loop + if Chunk.Next /= null then + + -- Release unused non-first empty chunk + + if Chunk.Prev /= null and then Chunk.First = Stack.Top then + To_Be_Released_Chunk := Chunk; + Chunk := Chunk.Prev; + Chunk.Next := To_Be_Released_Chunk.Next; + To_Be_Released_Chunk.Next.Prev := Chunk; + Free (To_Be_Released_Chunk); + end if; - -- Create new chunk of the default size unless it is not sufficient + -- Create new chunk of default size unless it is not + -- sufficient to satisfy the current request. - elsif SSE.Storage_Count (Max_Size) <= Stack.Default_Size then - Chunk.Next := new Chunk_Id ( - First => Chunk.Last + 1, - Last => Chunk.Last + Mark_Id (Stack.Default_Size)); + elsif SSE.Storage_Count (Max_Size) <= Stack.Default_Size then + Chunk.Next := + new Chunk_Id + (First => Chunk.Last + 1, + Last => Chunk.Last + Mark_Id (Stack.Default_Size)); - Chunk.Next.Prev := Chunk; + Chunk.Next.Prev := Chunk; - else - Chunk.Next := new Chunk_Id ( - First => Chunk.Last + 1, - Last => Chunk.Last + Max_Size); + -- Otherwise create new chunk of requested size - Chunk.Next.Prev := Chunk; - end if; + else + Chunk.Next := + new Chunk_Id + (First => Chunk.Last + 1, + Last => Chunk.Last + Max_Size); - Chunk := Chunk.Next; - Stack.Top := Chunk.First; - end loop; + Chunk.Next.Prev := Chunk; + end if; - -- Resulting address is the address pointed by Stack.Top + Chunk := Chunk.Next; + Stack.Top := Chunk.First; + end loop; - Address := Chunk.Mem (Stack.Top)'Address; - Stack.Top := Stack.Top + Max_Size; - Stack.Current_Chunk := Chunk; + -- Resulting address is the address pointed by Stack.Top + + Addr := Chunk.Mem (Stack.Top)'Address; + Stack.Top := Stack.Top + Max_Size; + Stack.Current_Chunk := Chunk; + end; + end if; end SS_Allocate; ------------- -- SS_Free -- ------------- - procedure SS_Free (Stk : in out System.Address) is - Stack : Stack_Ptr; - Chunk : Chunk_Ptr; - - procedure Free is new Unchecked_Deallocation (Stack_Id, Stack_Ptr); - + procedure SS_Free (Stk : in out Address) is begin + -- Case of statically allocated secondary stack, nothing to free + if not SS_Ratio_Dynamic then return; - end if; - Stack := From_Addr (Stk); - Chunk := Stack.Current_Chunk; + -- Case of dynamically allocated secondary stack + + else + declare + Stack : Stack_Ptr := To_Stack_Ptr (Stk); + Chunk : Chunk_Ptr; - while Chunk.Prev /= null loop - Chunk := Chunk.Prev; - end loop; + procedure Free is new Unchecked_Deallocation (Stack_Id, Stack_Ptr); - while Chunk.Next /= null loop - Chunk := Chunk.Next; - Free (Chunk.Prev); - end loop; + begin + Chunk := Stack.Current_Chunk; + + while Chunk.Prev /= null loop + Chunk := Chunk.Prev; + end loop; - Free (Chunk); - Free (Stack); - Stk := Null_Address; + while Chunk.Next /= null loop + Chunk := Chunk.Next; + Free (Chunk.Prev); + end loop; + + Free (Chunk); + Free (Stack); + Stk := Null_Address; + end; + end if; end SS_Free; + ---------------- + -- SS_Get_Max -- + ---------------- + + function SS_Get_Max return Long_Long_Integer is + begin + if SS_Ratio_Dynamic then + return -1; + else + declare + Fixed_Stack : constant Fixed_Stack_Ptr := + To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); + begin + return Long_Long_Integer (Fixed_Stack.Max); + end; + end if; + end SS_Get_Max; + ------------- -- SS_Info -- ------------- procedure SS_Info is - Stack : constant Stack_Ptr := - From_Addr (SSL.Get_Sec_Stack_Addr.all); - Fixed_Stack : Fixed_Stack_Ptr; - Nb_Chunks : Integer := 1; - Chunk : Chunk_Ptr := Stack.Current_Chunk; - begin Put_Line ("Secondary Stack information:"); + -- Case of fixed secondary stack + if not SS_Ratio_Dynamic then - Fixed_Stack := To_Fixed (Stack); - Put_Line ( - " Total size : " - & Mark_Id'Image (Fixed_Stack.Last) - & " bytes"); - Put_Line ( - " Current allocated space : " - & Mark_Id'Image (Fixed_Stack.Top - 1) - & " bytes"); - return; - end if; + declare + Fixed_Stack : constant Fixed_Stack_Ptr := + To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); + + begin + Put_Line ( + " Total size : " + & Mark_Id'Image (Fixed_Stack.Last) + & " bytes"); + + Put_Line ( + " Current allocated space : " + & Mark_Id'Image (Fixed_Stack.Top - 1) + & " bytes"); + end; + + -- Case of dynamically allocated secondary stack + + else + declare + Stack : constant Stack_Ptr := + To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); + Nb_Chunks : Integer := 1; + Chunk : Chunk_Ptr := Stack.Current_Chunk; + + begin + while Chunk.Prev /= null loop + Chunk := Chunk.Prev; + end loop; - while Chunk.Prev /= null loop - Chunk := Chunk.Prev; - end loop; - - while Chunk.Next /= null loop - Nb_Chunks := Nb_Chunks + 1; - Chunk := Chunk.Next; - end loop; - - -- Current Chunk information - - Put_Line ( - " Total size : " - & Mark_Id'Image (Chunk.Last) - & " bytes"); - Put_Line ( - " Current allocated space : " - & Mark_Id'Image (Stack.Top - 1) - & " bytes"); - - Put_Line ( - " Number of Chunks : " - & Integer'Image (Nb_Chunks)); - - Put_Line ( - " Default size of Chunks : " - & SSE.Storage_Count'Image (Stack.Default_Size)); + while Chunk.Next /= null loop + Nb_Chunks := Nb_Chunks + 1; + Chunk := Chunk.Next; + end loop; + + -- Current Chunk information + + Put_Line ( + " Total size : " + & Mark_Id'Image (Chunk.Last) + & " bytes"); + + Put_Line ( + " Current allocated space : " + & Mark_Id'Image (Stack.Top - 1) + & " bytes"); + + Put_Line ( + " Number of Chunks : " + & Integer'Image (Nb_Chunks)); + + Put_Line ( + " Default size of Chunks : " + & SSE.Storage_Count'Image (Stack.Default_Size)); + end; + end if; end SS_Info; ------------- @@ -292,33 +415,41 @@ package body System.Secondary_Stack is ------------- procedure SS_Init - (Stk : in out System.Address; + (Stk : in out Address; Size : Natural := Default_Secondary_Stack_Size) is - Stack : Stack_Ptr; - Fixed_Stack : Fixed_Stack_Ptr; - begin - if not SS_Ratio_Dynamic then - Fixed_Stack := To_Fixed (From_Addr (Stk)); - Fixed_Stack.Top := Fixed_Stack.Mem'First; - - if Size < 2 * Mark_Id'Max_Size_In_Storage_Elements then - Fixed_Stack.Last := 0; - else - Fixed_Stack.Last := Mark_Id (Size) - - 2 * Mark_Id'Max_Size_In_Storage_Elements; - end if; + -- Case of fixed size secondary stack - return; + if not SS_Ratio_Dynamic then + declare + Fixed_Stack : Fixed_Stack_Ptr := To_Fixed_Stack_Ptr (Stk); + + begin + Fixed_Stack.Top := 0; + Fixed_Stack.Max := 0; + + if Size < Dummy_Fixed_Stack.Mem'Position then + Fixed_Stack.Last := 0; + else + Fixed_Stack.Last := + Mark_Id (Size) - Dummy_Fixed_Stack.Mem'Position; + end if; + end; + + -- Case of dynamically allocated secondary stack + + else + declare + Stack : Stack_Ptr; + begin + Stack := new Stack_Id; + Stack.Current_Chunk := new Chunk_Id (1, Mark_Id (Size)); + Stack.Top := 1; + Stack.Default_Size := SSE.Storage_Count (Size); + Stk := To_Addr (Stack); + end; end if; - - Stack := new Stack_Id; - Stack.Current_Chunk := new Chunk_Id (1, Mark_Id (Size)); - Stack.Top := 1; - Stack.Default_Size := SSE.Storage_Count (Size); - - Stk := To_Addr (Stack); end SS_Init; ------------- @@ -327,7 +458,11 @@ package body System.Secondary_Stack is function SS_Mark return Mark_Id is begin - return From_Addr (SSL.Get_Sec_Stack_Addr.all).Top; + if SS_Ratio_Dynamic then + return To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all).Top; + else + return To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all).Top; + end if; end SS_Mark; ---------------- @@ -336,30 +471,35 @@ package body System.Secondary_Stack is procedure SS_Release (M : Mark_Id) is begin - From_Addr (SSL.Get_Sec_Stack_Addr.all).Top := M; + if SS_Ratio_Dynamic then + To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all).Top := M; + else + To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all).Top := M; + end if; end SS_Release; ------------------------- -- Package Elaboration -- ------------------------- - -- Allocate a secondary stack for the main program to use. + -- Allocate a secondary stack for the main program to use + -- We make sure that the stack has maximum alignment. Some systems require -- this (e.g. Sun), and in any case it is a good idea for efficiency. Stack : aliased Stack_Id; for Stack'Alignment use Standard'Maximum_Alignment; - Chunk : aliased Chunk_Id (1, Default_Secondary_Stack_Size); + Chunk : aliased Chunk_Id (1, Mark_Id (Default_Secondary_Stack_Size)); for Chunk'Alignment use Standard'Maximum_Alignment; - Chunk_Address : System.Address; + Chunk_Address : Address; begin if SS_Ratio_Dynamic then Stack.Top := 1; Stack.Current_Chunk := Chunk'Access; - Stack.Default_Size := Default_Secondary_Stack_Size; + Stack.Default_Size := SSE.Storage_Offset (Default_Secondary_Stack_Size); System.Soft_Links.Set_Sec_Stack_Addr_NT (Stack'Address); else diff --git a/gcc/ada/s-secsta.ads b/gcc/ada/s-secsta.ads index e292d6a..b539a3b 100644 --- a/gcc/ada/s-secsta.ads +++ b/gcc/ada/s-secsta.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -37,11 +37,11 @@ package System.Secondary_Stack is package SSE renames System.Storage_Elements; - Default_Secondary_Stack_Size : constant := 10 * 1024; - -- Default size of a secondary stack + Default_Secondary_Stack_Size : Natural := 10 * 1024; + -- Default size of a secondary stack. May be modified by binder -D switch procedure SS_Init - (Stk : in out System.Address; + (Stk : in out Address; Size : Natural := Default_Secondary_Stack_Size); -- Initialize the secondary stack with a main stack of the given Size. -- @@ -62,15 +62,15 @@ package System.Secondary_Stack is -- stack using System.Soft_Links.Get_Sec_Stack_Addr. procedure SS_Allocate - (Address : out System.Address; + (Addr : out Address; Storage_Size : SSE.Storage_Count); -- Allocate enough space for a 'Storage_Size' bytes object with Maximum - -- alignment. The address of the allocated space is returned in 'Address' + -- alignment. The address of the allocated space is returned in Addr. - procedure SS_Free (Stk : in out System.Address); - -- Release the memory allocated for the Secondary Stack. That is to say, - -- all the allocated chuncks. - -- Upon return, Stk will be set to System.Null_Address + procedure SS_Free (Stk : in out Address); + -- Release the memory allocated for the Secondary Stack. That is + -- to say, all the allocated chunks. Upon return, Stk will be set + -- to System.Null_Address. type Mark_Id is private; -- Type used to mark the stack. @@ -82,6 +82,14 @@ package System.Secondary_Stack is -- Restore the state of the stack corresponding to the mark M. If an -- additional chunk have been allocated, it will never be freed during a + function SS_Get_Max return Long_Long_Integer; + -- Return maximum used space in storage units for the current secondary + -- stack. For a dynamically allocated secondary stack, the returned + -- result is always -1. For a statically allocated secondary stack, + -- the returned value shows the largest amount of space allocated so + -- far during execution of the program to the current secondary stack, + -- i.e. the secondary stack for the current task. + generic with procedure Put_Line (S : String); procedure SS_Info; diff --git a/gcc/ada/s-stalib.adb b/gcc/ada/s-stalib.adb index acb1a9b..e4a48af 100644 --- a/gcc/ada/s-stalib.adb +++ b/gcc/ada/s-stalib.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1995-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1995-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- -- @@ -64,7 +64,7 @@ package body System.Standard_Library is Inside_Elab_Final_Code : Integer := 0; pragma Export (C, Inside_Elab_Final_Code, "__gnat_inside_elab_final_code"); - -- ???This variable is obsolete starting from 29/08 but cannot be removed + -- ???This variable is obsolete since 2001-08-29 but cannot be removed -- ???right away due to the bootstrap problems -------------------------- diff --git a/gcc/ada/s-tasdeb.adb b/gcc/ada/s-tasdeb.adb index baca961..cc431d6 100644 --- a/gcc/ada/s-tasdeb.adb +++ b/gcc/ada/s-tasdeb.adb @@ -211,9 +211,7 @@ package body System.Tasking.Debug is -- Set_Trace -- --------------- - procedure Set_Trace - (Flag : Character; - Value : Boolean := True) is + procedure Set_Trace (Flag : Character; Value : Boolean := True) is begin Trace_On (Flag) := Value; end Set_Trace; @@ -278,7 +276,8 @@ package body System.Tasking.Debug is (Self_Id : Task_ID; Msg : String; Flag : Character; - Other_Id : Task_ID := null) is + Other_Id : Task_ID := null) + is begin if Trace_On (Flag) then Put (To_Integer (Self_Id)'Img & @@ -294,11 +293,16 @@ package body System.Tasking.Debug is end if; end Trace; - procedure Write (Fd : Integer; S : String; Count : Integer) is + ----------- + -- Write -- + ----------- - Num : Integer; + procedure Write (Fd : Integer; S : String; Count : Integer) is + Discard : Integer; + pragma Unreferenced (Discard); begin - Num := System.CRTL.write (Fd, S (S'First)'Address, Count); + Discard := System.CRTL.write (Fd, S (S'First)'Address, Count); + -- Is it really right to ignore write errors here ??? end Write; end System.Tasking.Debug; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 8629c4d..3887181 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -1424,7 +1424,7 @@ package body Sem_Attr is ------------ function On_X86 return Boolean is - T : String := Sdefault.Target_Name.all; + T : constant String := Sdefault.Target_Name.all; begin -- There is no clean way to check this. That's not surprising, diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 4fdf9a9..775ef64 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -2375,7 +2375,6 @@ package body Sem_Ch10 is procedure Expand_Limited_With_Clause (Nam : Node_Id; N : Node_Id) is Loc : constant Source_Ptr := Sloc (Nam); - P : Entity_Id; Unum : Unit_Number_Type; Withn : Node_Id; @@ -2398,8 +2397,6 @@ package body Sem_Ch10 is Subunit => False, Error_Node => Nam); - P := Cunit_Entity (Unum); - if not Analyzed (Cunit (Unum)) then Set_Library_Unit (Withn, Cunit (Unum)); Set_Corresponding_Spec @@ -2431,8 +2428,6 @@ package body Sem_Ch10 is Subunit => False, Error_Node => Nam); - P := Cunit_Entity (Unum); - if not Analyzed (Cunit (Unum)) then Set_Library_Unit (Withn, Cunit (Unum)); Set_Corresponding_Spec @@ -3242,9 +3237,9 @@ package body Sem_Ch10 is ------------------------------- procedure Install_Limited_Withed_Unit (N : Node_Id) is - Unum : Unit_Number_Type := + Unum : constant Unit_Number_Type := Get_Source_Unit (Library_Unit (N)); - P_Unit : Entity_Id := Unit (Library_Unit (N)); + P_Unit : constant Entity_Id := Unit (Library_Unit (N)); P : Entity_Id; Lim_Elmt : Elmt_Id; Lim_Typ : Entity_Id; @@ -3584,9 +3579,8 @@ package body Sem_Ch10 is ------------------------- procedure Build_Limited_Views (N : Node_Id) is - - Unum : Unit_Number_Type := Get_Source_Unit (Library_Unit (N)); - P : Entity_Id := Cunit_Entity (Unum); + Unum : constant Unit_Number_Type := Get_Source_Unit (Library_Unit (N)); + P : constant Entity_Id := Cunit_Entity (Unum); Spec : Node_Id; -- To denote a package specification Lim_Typ : Entity_Id; -- To denote shadow entities. @@ -3717,9 +3711,9 @@ package body Sem_Ch10 is -- Could use more comments below ??? procedure Build_Chain (Spec : Node_Id; Scope : Entity_Id) is - Decl : Node_Id; - Analyzed_Unit : Boolean := Analyzed (Cunit (Unum)); + Analyzed_Unit : constant Boolean := Analyzed (Cunit (Unum)); Is_Tagged : Boolean; + Decl : Node_Id; begin Decl := First (Visible_Declarations (Spec)); @@ -3788,7 +3782,7 @@ package body Sem_Ch10 is -- Local package declare - Spec : Node_Id := Specification (Decl); + Spec : constant Node_Id := Specification (Decl); begin Comp_Typ := Defining_Unit_Name (Spec); @@ -4077,7 +4071,7 @@ package body Sem_Ch10 is -------------------------------- procedure Remove_Limited_With_Clause (N : Node_Id) is - P_Unit : Entity_Id := Unit (Library_Unit (N)); + P_Unit : constant Entity_Id := Unit (Library_Unit (N)); P : Entity_Id := Defining_Unit_Name (Specification (P_Unit)); Lim_Elmt : Elmt_Id; Lim_Typ : Entity_Id; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 1676ee8..6820fe0 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -2577,7 +2577,7 @@ package body Sem_Ch12 is if In_Open_Scopes (Scope (Scope (Gen_Unit))) then declare - Decl : Node_Id := + Decl : constant Node_Id := Original_Node (Unit_Declaration_Node (Scope (Gen_Unit))); begin @@ -6248,7 +6248,7 @@ package body Sem_Ch12 is Gen_Anc : Entity_Id) return Boolean is - Gen_Par : Entity_Id := Generic_Parent (Act_Spec); + Gen_Par : constant Entity_Id := Generic_Parent (Act_Spec); begin if No (Gen_Par) then @@ -7768,8 +7768,7 @@ package body Sem_Ch12 is begin Decl := First (Actual_Decls); - - while (Present (Decl)) loop + while Present (Decl) loop if Nkind (Decl) = N_Subtype_Declaration and then Chars (Defining_Identifier (Decl)) = Chars (Etype (A_Gen_T)) diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index e122af7..e2d3c6c 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -209,10 +209,9 @@ package body Sem_Ch4 is -- a more informative message. function Try_Indexed_Call - (N : Node_Id; - Nam : Entity_Id; - Typ : Entity_Id) - return Boolean; + (N : Node_Id; + Nam : Entity_Id; + Typ : Entity_Id) return Boolean; -- If a function has defaults for all its actuals, a call to it may -- in fact be an indexing on the result of the call. Try_Indexed_Call -- attempts the interpretation as an indexing, prior to analysis as @@ -220,10 +219,9 @@ package body Sem_Ch4 is -- interpretations (same symbol but two different types). function Try_Indirect_Call - (N : Node_Id; - Nam : Entity_Id; - Typ : Entity_Id) - return Boolean; + (N : Node_Id; + Nam : Entity_Id; + Typ : Entity_Id) return Boolean; -- Similarly, a function F that needs no actuals can return an access -- to a subprogram, and the call F (X) interpreted as F.all (X). In -- this case the call may be overloaded with both interpretations. @@ -334,10 +332,6 @@ package body Sem_Ch4 is Check_Fully_Declared (Type_Id, N); Set_Directly_Designated_Type (Acc_Type, Type_Id); - if Is_Protected_Type (Type_Id) then - Check_Restriction (No_Protected_Type_Allocators, N); - end if; - if Is_Limited_Type (Type_Id) and then Comes_From_Source (N) and then not In_Instance_Body @@ -449,6 +443,15 @@ package body Sem_Ch4 is Set_Directly_Designated_Type (Acc_Type, Type_Id); Check_Fully_Declared (Type_Id, N); + -- Check restriction against dynamically allocated protected + -- objects. Note that when limited aggregates are supported, + -- a similar test should be applied to an allocator with a + -- qualified expression ??? + + if Is_Protected_Type (Type_Id) then + Check_Restriction (No_Protected_Type_Allocators, N); + end if; + -- Check for missing initialization. Skip this check if we already -- had errors on analyzing the allocator, since in that case these -- are probably cascaded errors @@ -4299,10 +4302,9 @@ package body Sem_Ch4 is ----------------------- function Try_Indirect_Call - (N : Node_Id; - Nam : Entity_Id; - Typ : Entity_Id) - return Boolean + (N : Node_Id; + Nam : Entity_Id; + Typ : Entity_Id) return Boolean is Actuals : constant List_Id := Parameter_Associations (N); Actual : Node_Id; @@ -4345,10 +4347,9 @@ package body Sem_Ch4 is ---------------------- function Try_Indexed_Call - (N : Node_Id; - Nam : Entity_Id; - Typ : Entity_Id) - return Boolean + (N : Node_Id; + Nam : Entity_Id; + Typ : Entity_Id) return Boolean is Actuals : constant List_Id := Parameter_Associations (N); Actual : Node_Id; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index ecb0034..d37b951 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -714,7 +714,7 @@ package body Sem_Ch5 is and then Serious_Errors_Detected = 0 then declare - Chosen : Node_Id := Find_Static_Alternative (N); + Chosen : constant Node_Id := Find_Static_Alternative (N); Alt : Node_Id; begin diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index caaf926..4edfee8 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -733,7 +733,7 @@ package body Sem_Ch7 is -------------------------------- procedure Generate_Parent_References is - Decl : Node_Id := Parent (N); + Decl : constant Node_Id := Parent (N); begin if Id = Cunit_Entity (Main_Unit) diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 6c65a7b..f207234 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.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- -- @@ -1240,7 +1240,8 @@ package body Sem_Ch8 is -- There is no need for elaboration checks on the new entity, which -- may be called before the next freezing point where the body will - -- appear. + -- appear. Elaboration checks refer to the real entity, not the one + -- created by the renaming declaration. Set_Kill_Elaboration_Checks (New_S, True); diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index f189fe1..bb62a11 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1997-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- -- @@ -300,7 +300,18 @@ package body Sem_Elab is Decl : Node_Id; E_Scope : Entity_Id; - -- Top level scope of entity for called subprogram + -- Top level scope of entity for called subprogram. This + -- value includes following renamings and derivations, so + -- this scope can be in a non-visible unit. This is the + -- scope that is to be investigated to see whether an + -- elaboration check is required. + + W_Scope : Entity_Id; + -- Top level scope of directly called entity for subprogram. + -- This differs from E_Scope in the case where renamings or + -- derivations are involved, since it does not follow these + -- links, thus W_Scope is always in a visible unit. This is + -- the scope for the Elaborate_All if one is needed. Body_Acts_As_Spec : Boolean; -- Set to true if call is to body acting as spec (no separate spec) @@ -611,7 +622,7 @@ package body Sem_Elab is Ent := Alias (Ent); E_Scope := Ent; - -- If no alias, there is a previous error. + -- If no alias, there is a previous error if No (Ent) then return; @@ -623,6 +634,26 @@ package body Sem_Elab is return; end if; + -- Find top level scope for called entity (not following renamings + -- or derivations). This is where the Elaborate_All will go if it + -- is needed. We start with the called entity, except in the case + -- of initialization procedures, where the init proc is in the root + -- package, where we start fromn the entity of the name in the call. + + if Is_Entity_Name (Name (N)) + and then Is_Init_Proc (Entity (Name (N))) + then + W_Scope := Scope (Entity (Name (N))); + else + W_Scope := E; + end if; + + while not Is_Compilation_Unit (W_Scope) loop + W_Scope := Scope (W_Scope); + end loop; + + -- Now check if an elaborate_all (or dynamic check) is needed + if not Suppress_Elaboration_Warnings (Ent) and then not Elaboration_Checks_Suppressed (Ent) and then not Suppress_Elaboration_Warnings (E_Scope) @@ -633,38 +664,23 @@ package body Sem_Elab is if Inst_Case then Error_Msg_NE ("instantiation of& may raise Program_Error?", N, Ent); + else if Is_Init_Proc (Entity (Name (N))) and then Comes_From_Source (Ent) then Error_Msg_NE - ("implicit call to & in initialization" & - " may raise Program_Error?", N, Ent); - E_Scope := Scope (Entity (Name (N))); + ("implicit call to & may raise Program_Error?", N, Ent); else Error_Msg_NE ("call to & may raise Program_Error?", N, Ent); end if; - - if Unit_Callee = No_Unit - and then E_Scope = Current_Scope - then - -- The missing pragma cannot be on the current unit, so - -- place it on the compilation unit that contains the - -- called entity, which is more likely to be right. - - E_Scope := Ent; - - while not Is_Compilation_Unit (E_Scope) loop - E_Scope := Scope (E_Scope); - end loop; - end if; end if; Error_Msg_Qual_Level := Nat'Last; Error_Msg_NE - ("\missing pragma Elaborate_All for&?", N, E_Scope); + ("\missing pragma Elaborate_All for&?", N, W_Scope); Error_Msg_Qual_Level := 0; Output_Calls (N); @@ -672,7 +688,7 @@ package body Sem_Elab is -- unless in All_Errors_Mode. if not All_Errors_Mode and not Dynamic_Elaboration_Checks then - Set_Suppress_Elaboration_Warnings (E_Scope, True); + Set_Suppress_Elaboration_Warnings (W_Scope, True); end if; end if; @@ -680,12 +696,18 @@ package body Sem_Elab is if Dynamic_Elaboration_Checks then if not Elaboration_Checks_Suppressed (Ent) + and then not Elaboration_Checks_Suppressed (W_Scope) and then not Elaboration_Checks_Suppressed (E_Scope) and then not Cunit_SC then -- Runtime elaboration check required. Generate check of the -- elaboration Boolean for the unit containing the entity. + -- Note that for this case, we do check the real unit (the + -- one from following renamings, since that is the issue!) + + -- Could this possibly miss a useless but required PE??? + Insert_Elab_Check (N, Make_Attribute_Reference (Loc, Attribute_Name => Name_Elaborated, @@ -694,25 +716,41 @@ package body Sem_Elab is (Spec_Entity (E_Scope), Loc))); end if; - -- If no dynamic check required, then ask binder to guarantee - -- that the necessary elaborations will be done properly! + -- Case of static elaboration model else - if not Suppress_Elaboration_Warnings (E) - and then not Elaboration_Checks_Suppressed (E) - and then not Suppress_Elaboration_Warnings (E_Scope) - and then not Elaboration_Checks_Suppressed (E_Scope) - and then Elab_Warnings - and then Generate_Warnings - and then not Inst_Case + -- Do not do anything if elaboration checks suppressed. Note + -- that we check Ent here, not E, since we want the real entity + -- for the body to see if checks are suppressed for it, not the + -- dummy entry for renamings or derivations. + + if Elaboration_Checks_Suppressed (Ent) + or else Elaboration_Checks_Suppressed (E_Scope) + or else Elaboration_Checks_Suppressed (W_Scope) then - Error_Msg_Node_2 := E_Scope; - Error_Msg_NE ("call to& in elaboration code " & - "requires pragma Elaborate_All on&?", N, E); - end if; + null; + + -- Here we need to generate an implicit elaborate all + + else + -- Generate elaborate_all warning unless suppressed - Set_Elaborate_All_Desirable (E_Scope); - Set_Suppress_Elaboration_Warnings (E_Scope, True); + if (Elab_Warnings and Generate_Warnings and not Inst_Case) + and then not Suppress_Elaboration_Warnings (Ent) + and then not Suppress_Elaboration_Warnings (E_Scope) + and then not Suppress_Elaboration_Warnings (W_Scope) + then + Error_Msg_Node_2 := W_Scope; + Error_Msg_NE + ("call to& in elaboration code " & + "requires pragma Elaborate_All on&?", N, E); + end if; + + -- Set indication for binder to generate Elaborate_All + + Set_Elaborate_All_Desirable (W_Scope); + Set_Suppress_Elaboration_Warnings (W_Scope, True); + end if; end if; -- Case of entity is in same unit as call or instantiation diff --git a/gcc/ada/sem_elim.adb b/gcc/ada/sem_elim.adb index bde2f98..c5c6b3a 100644 --- a/gcc/ada/sem_elim.adb +++ b/gcc/ada/sem_elim.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2003 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- -- @@ -33,6 +33,7 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; +with Table; with Uintp; use Uintp; with GNAT.HTable; use GNAT.HTable; @@ -91,6 +92,9 @@ package body Sem_Elim is Homonym : Access_Elim_Data; -- Pointer to next entry with same key + Prag : Node_Id; + -- Node_Id for Eliminate pragma + end record; ---------------- @@ -179,6 +183,14 @@ package body Sem_Elim is end Set_Next; end Hash_Subprograms; + ------------ + -- Tables -- + ------------ + + -- The following table records the data for each pragmas, using the + -- entity name as the hash key for retrieval. Entries in this table + -- are set by Process_Eliminate_Pragma and read by Check_Eliminated. + package Elim_Hash_Table is new Static_HTable ( Header_Num => Header_Num, Element => Element, @@ -191,6 +203,24 @@ package body Sem_Elim is Hash => Hash_Subprograms.Hash, Equal => Hash_Subprograms.Equal); + -- The following table records entities for subprograms that are + -- eliminated, and corresponding eliminate pragmas that caused the + -- elimination. Entries in this table are set by Check_Eliminated + -- and read by Eliminate_Error_Msg. + + type Elim_Entity_Entry is record + Prag : Node_Id; + Subp : Entity_Id; + end record; + + package Elim_Entities is new Table.Table ( + Table_Component_Type => Elim_Entity_Entry, + Table_Index_Type => Name_Id, + Table_Low_Bound => First_Name_Id, + Table_Initial => 50, + Table_Increment => 200, + Table_Name => "Elim_Entries"); + ---------------------- -- Check_Eliminated -- ---------------------- @@ -206,7 +236,7 @@ package body Sem_Elim is if No_Elimination then return; - -- Elimination of objects and types is not implemented yet. + -- Elimination of objects and types is not implemented yet elsif Ekind (E) not in Subprogram_Kind then return; @@ -217,142 +247,173 @@ package body Sem_Elim is -- Loop through homonyms for this key while Elmt /= null loop + declare + procedure Set_Eliminated; + -- Set current subprogram entity as eliminated - -- First we check that the name of the entity matches + procedure Set_Eliminated is + begin + Set_Is_Eliminated (E); + Elim_Entities.Append ((Prag => Elmt.Prag, Subp => E)); + end Set_Eliminated; - if Elmt.Entity_Name /= Chars (E) then - goto Continue; - end if; + begin + -- First we check that the name of the entity matches + + if Elmt.Entity_Name /= Chars (E) then + goto Continue; + end if; + + -- Then we need to see if the static scope matches within the + -- compilation unit. - -- Then we need to see if the static scope matches within the - -- compilation unit. + Scop := Scope (E); + if Elmt.Entity_Scope /= null then + for J in reverse Elmt.Entity_Scope'Range loop + if Elmt.Entity_Scope (J) /= Chars (Scop) then + goto Continue; + end if; - Scop := Scope (E); - if Elmt.Entity_Scope /= null then - for J in reverse Elmt.Entity_Scope'Range loop - if Elmt.Entity_Scope (J) /= Chars (Scop) then + Scop := Scope (Scop); + + if not Is_Compilation_Unit (Scop) and then J = 1 then + goto Continue; + end if; + end loop; + end if; + + -- Now see if compilation unit matches + + for J in reverse Elmt.Unit_Name'Range loop + if Elmt.Unit_Name (J) /= Chars (Scop) then goto Continue; end if; Scop := Scope (Scop); - if not Is_Compilation_Unit (Scop) and then J = 1 then + if Scop /= Standard_Standard and then J = 1 then goto Continue; end if; end loop; - end if; - - -- Now see if compilation unit matches - - for J in reverse Elmt.Unit_Name'Range loop - if Elmt.Unit_Name (J) /= Chars (Scop) then - goto Continue; - end if; - - Scop := Scope (Scop); - if Scop /= Standard_Standard and then J = 1 then + if Scop /= Standard_Standard then goto Continue; end if; - end loop; - - if Scop /= Standard_Standard then - goto Continue; - end if; - - -- Check for case of given entity is a library level subprogram - -- and we have the single parameter Eliminate case, a match! - - if Is_Compilation_Unit (E) - and then Is_Subprogram (E) - and then No (Elmt.Entity_Node) - then - Set_Is_Eliminated (E); - return; - - -- Check for case of type or object with two parameter case - elsif (Is_Type (E) or else Is_Object (E)) - and then Elmt.Result_Type = No_Name - and then Elmt.Parameter_Types = null - then - Set_Is_Eliminated (E); - return; - - -- Check for case of subprogram - - elsif Ekind (E) = E_Function - or else Ekind (E) = E_Procedure - then - -- If Homonym_Number present, then see if it matches - - if Elmt.Homonym_Number /= No_Uint then - Ctr := 1; - - Ent := E; - while Present (Homonym (Ent)) - and then Scope (Ent) = Scope (Homonym (Ent)) - loop - Ctr := Ctr + 1; - Ent := Homonym (Ent); - end loop; + -- Check for case of given entity is a library level subprogram + -- and we have the single parameter Eliminate case, a match! + + if Is_Compilation_Unit (E) + and then Is_Subprogram (E) + and then No (Elmt.Entity_Node) + then + Set_Eliminated; + return; + + -- Check for case of type or object with two parameter case + + elsif (Is_Type (E) or else Is_Object (E)) + and then Elmt.Result_Type = No_Name + and then Elmt.Parameter_Types = null + then + Set_Eliminated; + return; + + -- Check for case of subprogram + + elsif Ekind (E) = E_Function + or else Ekind (E) = E_Procedure + then + -- If Homonym_Number present, then see if it matches + + if Elmt.Homonym_Number /= No_Uint then + Ctr := 1; + + Ent := E; + while Present (Homonym (Ent)) + and then Scope (Ent) = Scope (Homonym (Ent)) + loop + Ctr := Ctr + 1; + Ent := Homonym (Ent); + end loop; - if Ctr /= Elmt.Homonym_Number then - goto Continue; + if Ctr /= Elmt.Homonym_Number then + goto Continue; + end if; end if; - end if; - -- If we have a Result_Type, then we must have a function - -- with the proper result type + -- If we have a Result_Type, then we must have a function + -- with the proper result type - if Elmt.Result_Type /= No_Name then - if Ekind (E) /= E_Function - or else Chars (Etype (E)) /= Elmt.Result_Type - then - goto Continue; + if Elmt.Result_Type /= No_Name then + if Ekind (E) /= E_Function + or else Chars (Etype (E)) /= Elmt.Result_Type + then + goto Continue; + end if; end if; - end if; - -- If we have Parameter_Types, they must match + -- If we have Parameter_Types, they must match - if Elmt.Parameter_Types /= null then - Form := First_Formal (E); + if Elmt.Parameter_Types /= null then + Form := First_Formal (E); - if No (Form) and then Elmt.Parameter_Types = null then - null; + if No (Form) and then Elmt.Parameter_Types = null then + null; - elsif Elmt.Parameter_Types = null then - goto Continue; + elsif Elmt.Parameter_Types = null then + goto Continue; - else - for J in Elmt.Parameter_Types'Range loop - if No (Form) - or else Chars (Etype (Form)) /= Elmt.Parameter_Types (J) - then + else + for J in Elmt.Parameter_Types'Range loop + if No (Form) + or else + Chars (Etype (Form)) /= Elmt.Parameter_Types (J) + then + goto Continue; + else + Next_Formal (Form); + end if; + end loop; + + if Present (Form) then goto Continue; - else - Next_Formal (Form); end if; - end loop; - - if Present (Form) then - goto Continue; end if; end if; - end if; - -- If we fall through, this is match + -- If we fall through, this is match - Set_Is_Eliminated (E); - return; - end if; + Set_Eliminated; + return; + end if; - <<Continue>> Elmt := Elmt.Homonym; + <<Continue>> Elmt := Elmt.Homonym; + end; end loop; return; end Check_Eliminated; + ------------------------- + -- Eliminate_Error_Msg -- + ------------------------- + + procedure Eliminate_Error_Msg (N : Node_Id; E : Entity_Id) is + begin + for J in Elim_Entities.First .. Elim_Entities.Last loop + if E = Elim_Entities.Table (J).Subp then + Error_Msg_Sloc := Sloc (Elim_Entities.Table (J).Prag); + Error_Msg_NE ("cannot call subprogram & eliminated #", N, E); + return; + end if; + end loop; + + -- Should never fall through, since entry should be in table + + pragma Assert (False); + end Eliminate_Error_Msg; + ---------------- -- Initialize -- ---------------- @@ -360,6 +421,7 @@ package body Sem_Elim is procedure Initialize is begin Elim_Hash_Table.Reset; + Elim_Entities.Init; No_Elimination := True; end Initialize; @@ -368,7 +430,8 @@ package body Sem_Elim is ------------------------------ procedure Process_Eliminate_Pragma - (Arg_Unit_Name : Node_Id; + (Pragma_Node : Node_Id; + Arg_Unit_Name : Node_Id; Arg_Entity : Node_Id; Arg_Parameter_Types : Node_Id; Arg_Result_Type : Node_Id; @@ -416,6 +479,7 @@ package body Sem_Elim is -- Start of processing for Process_Eliminate_Pragma begin + Data.Prag := Pragma_Node; Error_Msg_Name_1 := Name_Eliminate; -- Process Unit_Name argument diff --git a/gcc/ada/sem_elim.ads b/gcc/ada/sem_elim.ads index 98d45d8..133219e 100644 --- a/gcc/ada/sem_elim.ads +++ b/gcc/ada/sem_elim.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1997-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2003 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- -- @@ -34,21 +34,30 @@ package Sem_Elim is -- Initialize for new main souce program procedure Process_Eliminate_Pragma - (Arg_Unit_Name : Node_Id; + (Pragma_Node : Node_Id; + Arg_Unit_Name : Node_Id; Arg_Entity : Node_Id; Arg_Parameter_Types : Node_Id; Arg_Result_Type : Node_Id; Arg_Homonym_Number : Node_Id); - -- Process eliminate pragma. The number of arguments has been checked, - -- as well as possible optional identifiers, but no other checks have - -- been made. This subprogram completes the checking, and then if the - -- pragma is well formed, makes appropriate entries in the internal - -- tables used to keep track of Eliminate pragmas. The five arguments - -- are expressions (not pragma argument associations) for the possible - -- pragma arguments. A parameter that is not present is set to Empty. + -- Process eliminate pragma (given by Pragma_Node). The number of + -- arguments has been checked, as well as possible optional identifiers, + -- but no other checks have been made. This subprogram completes the + -- checking, and then if the pragma is well formed, makes appropriate + -- entries in the internal tables used to keep track of Eliminate pragmas. + -- The other five arguments are expressions (rather than pragma argument + -- associations) for the possible pragma arguments. A parameter that + -- is not present is set to Empty. procedure Check_Eliminated (E : Entity_Id); -- Checks if entity E is eliminated, and if so sets the Is_Eliminated -- flag on the given entity. + procedure Eliminate_Error_Msg (N : Node_Id; E : Entity_Id); + -- Called by the back end on encouterning a call to an eliminated + -- subprogram. N is the node for the call, and E is the entity of + -- the subprogram being eliminated. + + + end Sem_Elim; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index cc6d6f3..222355d1 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -2279,63 +2279,91 @@ package body Sem_Eval is ------------------------- procedure Eval_String_Literal (N : Node_Id) is - T : constant Entity_Id := Etype (N); - B : constant Entity_Id := Base_Type (T); - I : Entity_Id; + Typ : constant Entity_Id := Etype (N); + Bas : constant Entity_Id := Base_Type (Typ); + Xtp : Entity_Id; + Len : Nat; + Lo : Node_Id; begin -- Nothing to do if error type (handles cases like default expressions -- or generics where we have not yet fully resolved the type) - if B = Any_Type or else B = Any_String then + if Bas = Any_Type or else Bas = Any_String then return; + end if; -- String literals are static if the subtype is static (RM 4.9(2)), so -- reset the static expression flag (it was set unconditionally in -- Analyze_String_Literal) if the subtype is non-static. We tell if -- the subtype is static by looking at the lower bound. - elsif not Is_OK_Static_Expression (String_Literal_Low_Bound (T)) then + if Ekind (Typ) = E_String_Literal_Subtype then + if not Is_OK_Static_Expression (String_Literal_Low_Bound (Typ)) then + Set_Is_Static_Expression (N, False); + return; + end if; + + -- Here if Etype of string literal is normal Etype (not yet possible, + -- but may be possible in future!) + + elsif not Is_OK_Static_Expression + (Type_Low_Bound (Etype (First_Index (Typ)))) + then Set_Is_Static_Expression (N, False); + return; + end if; + + -- If original node was a type conversion, then result if non-static - elsif Nkind (Original_Node (N)) = N_Type_Conversion then + if Nkind (Original_Node (N)) = N_Type_Conversion then Set_Is_Static_Expression (N, False); + return; + end if; -- Test for illegal Ada 95 cases. A string literal is illegal in -- Ada 95 if its bounds are outside the index base type and this - -- index type is static. This can hapen in only two ways. Either + -- index type is static. This can happen in only two ways. Either -- the string literal is too long, or it is null, and the lower -- bound is type'First. In either case it is the upper bound that -- is out of range of the index type. - elsif Ada_95 then - if Root_Type (B) = Standard_String - or else Root_Type (B) = Standard_Wide_String + if Ada_95 then + if Root_Type (Bas) = Standard_String + or else + Root_Type (Bas) = Standard_Wide_String then - I := Standard_Positive; + Xtp := Standard_Positive; else - I := Etype (First_Index (B)); + Xtp := Etype (First_Index (Bas)); end if; - if String_Literal_Length (T) > String_Type_Len (B) then + if Ekind (Typ) = E_String_Literal_Subtype then + Lo := String_Literal_Low_Bound (Typ); + else + Lo := Type_Low_Bound (Etype (First_Index (Typ))); + end if; + + Len := String_Length (Strval (N)); + + if UI_From_Int (Len) > String_Type_Len (Bas) then Apply_Compile_Time_Constraint_Error (N, "string literal too long for}", CE_Length_Check_Failed, - Ent => B, - Typ => First_Subtype (B)); + Ent => Bas, + Typ => First_Subtype (Bas)); - elsif String_Literal_Length (T) = 0 - and then not Is_Generic_Type (I) - and then Expr_Value (String_Literal_Low_Bound (T)) = - Expr_Value (Type_Low_Bound (Base_Type (I))) + elsif Len = 0 + and then not Is_Generic_Type (Xtp) + and then + Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp))) then Apply_Compile_Time_Constraint_Error (N, "null string literal not allowed for}", CE_Length_Check_Failed, - Ent => B, - Typ => First_Subtype (B)); + Ent => Bas, + Typ => First_Subtype (Bas)); end if; end if; - end Eval_String_Literal; -------------------------- diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index f080512..4ad662d 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.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- -- @@ -2763,6 +2763,7 @@ package body Sem_Prag is declare Decl : constant Node_Id := Unit_Declaration_Node (Def_Id); + begin if Present (Decl) and then Nkind (Decl) = N_Subprogram_Declaration @@ -2856,7 +2857,7 @@ package body Sem_Prag is ---------------------------- function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean is - Decl : Node_Id := Unit_Declaration_Node (Subp); + Decl : constant Node_Id := Unit_Declaration_Node (Subp); begin if Nkind (Decl) = N_Subprogram_Body then @@ -4186,7 +4187,8 @@ package body Sem_Prag is if Expander_Active then declare - Temp : Node_Id := New_Copy_Tree (Expression (Arg2)); + Temp : constant Node_Id := + New_Copy_Tree (Expression (Arg2)); begin Set_Parent (Temp, N); Pre_Analyze_And_Resolve (Temp, RTE (RE_Interrupt_ID)); @@ -5293,7 +5295,8 @@ package body Sem_Prag is end if; Process_Eliminate_Pragma - (Unit_Name, + (N, + Unit_Name, Entity, Parameter_Types, Result_Type, @@ -7378,9 +7381,13 @@ package body Sem_Prag is No_Run_Time_Mode := True; Configurable_Run_Time_Mode := True; - if Ttypes.System_Word_Size = 32 then - Duration_32_Bits_On_Target := True; - end if; + declare + Word32 : constant Boolean := Ttypes.System_Word_Size = 32; + begin + if Word32 then + Duration_32_Bits_On_Target := True; + end if; + end; Restrictions (No_Finalization) := True; Restrictions (No_Exception_Handlers) := True; @@ -9776,7 +9783,7 @@ package body Sem_Prag is -- than appearence as any argument is insignificant, a positive value -- indicates that appearence in that parameter position is significant. - Sig_Flags : array (Pragma_Id) of Int := + Sig_Flags : constant array (Pragma_Id) of Int := (Pragma_AST_Entry => -1, Pragma_Abort_Defer => -1, Pragma_Ada_83 => -1, diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 51971d1..7bcd986 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.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- -- @@ -1832,7 +1832,24 @@ package body Sem_Res is -- doesn't think of them this way!) if Typ = Standard_Void_Type then - Error_Msg_N ("expect procedure name in procedure call", N); + + -- Special case message if function used as a procedure + + if Nkind (N) = N_Procedure_Call_Statement + and then Is_Entity_Name (Name (N)) + and then Ekind (Entity (Name (N))) = E_Function + then + Error_Msg_NE + ("cannot use function & in a procedure call", + Name (N), Entity (Name (N))); + + -- Otherwise give general message (not clear what cases + -- this covers, but no harm in providing for them!) + + else + Error_Msg_N ("expect procedure name in procedure call", N); + end if; + Found := True; -- Otherwise we do have a subexpression with the wrong type @@ -6535,10 +6552,10 @@ package body Sem_Res is Subtype_Id := Create_Itype (E_String_Literal_Subtype, N); end if; - Set_String_Literal_Length (Subtype_Id, - UI_From_Int (String_Length (Strval (N)))); - Set_Etype (Subtype_Id, Base_Type (Typ)); - Set_Is_Constrained (Subtype_Id); + Set_String_Literal_Length (Subtype_Id, UI_From_Int + (String_Length (Strval (N)))); + Set_Etype (Subtype_Id, Base_Type (Typ)); + Set_Is_Constrained (Subtype_Id); -- The low bound is set from the low bound of the corresponding -- index type. Note that we do not store the high bound in the diff --git a/gcc/ada/sem_res.ads b/gcc/ada/sem_res.ads index 895b54d..402331f 100644 --- a/gcc/ada/sem_res.ads +++ b/gcc/ada/sem_res.ads @@ -59,7 +59,6 @@ package Sem_Res is -- specified check suppressed (can be All_Checks to suppress all checks). procedure Resolve (N : Node_Id); - pragma Inline (Resolve); -- A version of Resolve where the type to be used for resolution is -- taken from the Etype (N). This is commonly used in cases where the -- context does not add anything and the first pass of analysis found @@ -118,4 +117,10 @@ package Sem_Res is -- Same, but use type of node because context does not impose a single -- type. +private + procedure Resolve_Implicit_Type (N : Node_Id) renames Resolve; + pragma Inline (Resolve_Implicit_Type); + -- We use this renaming to make the application of Inline very explicit + -- to this version, since other versions of Resolve are not inlined. + end Sem_Res; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 57f9317..269e132 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -3554,13 +3554,13 @@ package body Sem_Util is function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is Loc : constant Source_Ptr := Sloc (Typ); + Constraints : constant List_Id := New_List; + Components : constant Elist_Id := New_Elmt_List; Comp_Elmt : Elmt_Id; Comp_Id : Node_Id; Comp_List : Node_Id; Discr : Entity_Id; Discr_Val : Node_Id; - Constraints : List_Id := New_List; - Components : Elist_Id := New_Elmt_List; Report_Errors : Boolean; begin @@ -6038,13 +6038,14 @@ package body Sem_Util is ----------------------- function Type_Access_Level (Typ : Entity_Id) return Uint is - Btyp : Entity_Id := Base_Type (Typ); + Btyp : Entity_Id; begin -- If the type is an anonymous access type we treat it as being -- declared at the library level to ensure that names such as -- X.all'access don't fail static accessibility checks. + Btyp := Base_Type (Typ); if Ekind (Btyp) in Access_Kind then if Ekind (Btyp) = E_Anonymous_Access_Type then return Scope_Depth (Standard_Standard); diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 925b5c4..9b8c4c1 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -639,7 +639,7 @@ package Sem_Util is procedure Process_End_Label (N : Node_Id; Typ : Character; - Ent : Entity_Id); + Ent : Entity_Id); -- N is a node whose End_Label is to be processed, generating all -- appropriate cross-reference entries, and performing style checks -- for any identifier references in the end label. Typ is either @@ -776,7 +776,7 @@ package Sem_Util is -- Is_Public based upon the new scope. function Type_Access_Level (Typ : Entity_Id) return Uint; - -- Return the accessibility level of Typ. + -- Return the accessibility level of Typ function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id; -- Unit_Id is the simple name of a program unit, this function returns diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index c0ac7bc..7fe0a83 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -90,7 +90,7 @@ package body Sprint is -- with a lower precedence than the operator (or equal precedence if -- appearing as the right operand), then parentheses are required. - Op_Prec : array (N_Subexpr) of Short_Short_Integer := + Op_Prec : constant array (N_Subexpr) of Short_Short_Integer := (N_Op_And => 1, N_Op_Or => 1, N_Op_Xor => 1, diff --git a/gcc/ada/switch-b.adb b/gcc/ada/switch-b.adb index ecc022e..8cf9cf4 100644 --- a/gcc/ada/switch-b.adb +++ b/gcc/ada/switch-b.adb @@ -24,9 +24,9 @@ -- -- ------------------------------------------------------------------------------ -with Debug; use Debug; -with Osint; use Osint; -with Opt; use Opt; +with Debug; use Debug; +with Osint; use Osint; +with Opt; use Opt; with System.WCh_Con; use System.WCh_Con; @@ -58,7 +58,6 @@ package body Switch.B is then Osint.Fail ("invalid switch: """, Switch_Chars, """" & " (gnat not needed here)"); - end if; -- Loop to scan through switches given in switch string @@ -132,6 +131,12 @@ package body Switch.B is return; + -- Processing for D switch + + when 'D' => + Ptr := Ptr + 1; + Scan_Pos (Switch_Chars, Max, Ptr, Default_Sec_Stack_Size); + -- Processing for e switch when 'e' => diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index 2387cec..7ac45a0 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -469,13 +469,27 @@ package body Switch.C is when 'g' => Ptr := Ptr + 1; - GNAT_Mode := True; - Identifier_Character_Set := 'n'; - Warning_Mode := Treat_As_Error; - Check_Unreferenced := True; - Check_Withs := True; - Check_Unreferenced_Formals := True; - System_Extend_Unit := Empty; + GNAT_Mode := True; + Identifier_Character_Set := 'n'; + System_Extend_Unit := Empty; + Warning_Mode := Treat_As_Error; + + -- Set default warnings (basically -gnatwa) + + Check_Unreferenced := True; + Check_Unreferenced_Formals := True; + Check_Withs := True; + Constant_Condition_Warnings := True; + Implementation_Unit_Warnings := True; + Ineffective_Inline_Warnings := True; + Warn_On_Constant := True; + Warn_On_Export_Import := True; + Warn_On_Modified_Unread := True; + Warn_On_No_Value_Assigned := True; + Warn_On_Obsolescent_Feature := True; + Warn_On_Redundant_Constructs := True; + Warn_On_Unchecked_Conversion := True; + Warn_On_Unrecognized_Pragma := True; Set_Default_Style_Check_Options; diff --git a/gcc/ada/switch-m.adb b/gcc/ada/switch-m.adb index ec99f8f..9f37e03 100644 --- a/gcc/ada/switch-m.adb +++ b/gcc/ada/switch-m.adb @@ -484,6 +484,12 @@ package body Switch.M is Bind_Only := True; Make_Steps := True; + -- Processing for B switch + + when 'B' => + Ptr := Ptr + 1; + Build_Bind_And_Link_Full_Project := True; + -- Processing for c switch when 'c' => diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c index 9f443a6..c174fb0 100644 --- a/gcc/ada/trans.c +++ b/gcc/ada/trans.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2003, Free Software Foundation, Inc. * + * Copyright (C) 1992-2004, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -3940,6 +3940,15 @@ tree_transform (Node_Id gnat_node) tree gnu_obj_size; int align; + /* If this is a thin pointer, we must dereference it to create + a fat pointer, then go back below to a thin pointer. The + reason for this is that we need a fat pointer someplace in + order to properly compute the size. */ + if (TYPE_THIN_POINTER_P (TREE_TYPE (gnu_ptr))) + gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE, + build_unary_op (INDIRECT_REF, NULL_TREE, + gnu_ptr)); + /* If this is an unconstrained array, we know the object must have been allocated with the template in front of the object. So pass the template address, but get the total size. Do this diff --git a/gcc/ada/vms_conv.adb b/gcc/ada/vms_conv.adb index 479ecde..e352d80 100644 --- a/gcc/ada/vms_conv.adb +++ b/gcc/ada/vms_conv.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2004 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -24,6 +24,7 @@ -- -- ------------------------------------------------------------------------------ +with Gnatvsn; with Hostparm; with Osint; use Osint; @@ -31,8 +32,6 @@ with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; -with Gnatvsn; - package body VMS_Conv is Param_Count : Natural := 0; @@ -85,8 +84,7 @@ package body VMS_Conv is function Matching_Name (S : String; Itm : Item_Ptr; - Quiet : Boolean := False) - return Item_Ptr; + Quiet : Boolean := False) return Item_Ptr; -- Determines if the item list headed by Itm and threaded through the -- Next fields (with null marking the end of the list), contains an -- entry that uniquely matches the given string. The match is case @@ -452,8 +450,7 @@ package body VMS_Conv is function Matching_Name (S : String; Itm : Item_Ptr; - Quiet : Boolean := False) - return Item_Ptr + Quiet : Boolean := False) return Item_Ptr is P1, P2 : Item_Ptr; @@ -620,7 +617,7 @@ package body VMS_Conv is begin Put ("GNAT "); Put (Gnatvsn.Gnat_Version_String); - Put_Line (" Copyright 1996-2003 Free Software Foundation, Inc."); + Put_Line (" Copyright 1996-2004 Free Software Foundation, Inc."); end Output_Version; ----------- @@ -1049,8 +1046,7 @@ package body VMS_Conv is function Get_Arg_End (Argv : String; - Arg_Idx : Integer) - return Integer; + Arg_Idx : Integer) return Integer; -- Begins looking at Arg_Idx + 1 and returns the index of the -- last character before a slash or else the index of the last -- character in the string Argv. @@ -1061,8 +1057,7 @@ package body VMS_Conv is function Get_Arg_End (Argv : String; - Arg_Idx : Integer) - return Integer + Arg_Idx : Integer) return Integer is begin for J in Arg_Idx + 1 .. Argv'Last loop @@ -1399,8 +1394,8 @@ package body VMS_Conv is Arg1_Idx : Integer := Arg'First; function Get_Arg1_End - (Arg : String; Arg_Idx : Integer) - return Integer; + (Arg : String; + Arg_Idx : Integer) return Integer; -- Begins looking at Arg_Idx + 1 and -- returns the index of the last character -- before a comma or else the index of the @@ -1411,8 +1406,8 @@ package body VMS_Conv is ------------------ function Get_Arg1_End - (Arg : String; Arg_Idx : Integer) - return Integer + (Arg : String; + Arg_Idx : Integer) return Integer is begin for J in Arg_Idx + 1 .. Arg'Last loop diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index 74da709..3aa3837 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -3577,6 +3577,20 @@ package VMS_Data is -- /COMPILER_QUALIFIERS, /LINKER_QUALIFIERS and /MAKE_QUALIFIERS will be -- passed to any GNAT BIND commands generated by GNAT MAKE. + S_Make_Bindprj : aliased constant S := "/BND_LNK_FULL_PROJECT " & + "-B"; + -- /BND_LNK_FULL_PROJECT + -- + -- Bind and link all sources of a project, without any consideration + -- to attribute Main, if there is one. This qualifier need to be + -- used in conjunction with the /PROJECT_FILE= qualifier and cannot + -- be used with a main subprogram on the command line or for + -- a library project file. As the binder is invoked with the option + -- meaning "No Ada main subprogram", the user must ensure that the + -- proper options are specified to the linker. This qualifier is + -- normally used when the main subprogram is in a foreign language + -- such as C. + S_Make_Comp : aliased constant S := "/COMPILER_QUALIFIERS=?" & "-cargs COMPILE"; -- /COMPILER_QUALIFIERS @@ -4343,6 +4357,14 @@ package VMS_Data is -- Write the output into the specified file, overriding any possibly -- existing file. + S_Pretty_Formfeed : aliased constant S := "/FORM_FEED_AFTER_PRAGMA_PAGE " & + "-ff"; + -- /FORM_FEED_AFTER_PRAGMA_PAGE + -- + -- When there is a pragma Page in the source, insert a Form Feed + -- character immediately after the semicolon that follows the pragma + -- Page. + S_Pretty_Indent : aliased constant S := "/INDENTATION_LEVEL=#" & "-i#"; -- /INDENTATION_LEVEL=nnn @@ -4531,6 +4553,7 @@ package VMS_Data is S_Pretty_Current 'Access, S_Pretty_Dico 'Access, S_Pretty_Forced 'Access, + S_Pretty_Formfeed 'Access, S_Pretty_Indent 'Access, S_Pretty_Keyword 'Access, S_Pretty_Maxlen 'Access, diff --git a/gcc/ada/vxaddr2line.adb b/gcc/ada/vxaddr2line.adb index f8dc271..5fc7759 100644 --- a/gcc/ada/vxaddr2line.adb +++ b/gcc/ada/vxaddr2line.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002, 2003 Ada Core Technologies, Inc. -- +-- Copyright (C) 2002-2003 Ada Core Technologies, 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- -- @@ -26,17 +26,17 @@ -- This program is meant to be used with vxworks to compute symbolic -- backtraces on the host from non-symbolic backtraces obtained on the target. --- + -- The basic idea is to automate the computation of the necessary address -- adjustments prior to calling addr2line when the application has only been -- partially linked on the host. --- + -- Variants for various targets are supported, and the command line should -- be like : --- + -- <target>-addr2line [-a <target_arch>] <exe_file> <ref_address> -- <backtrace addresses> --- + -- Where: -- <target_arch> : -- selects the target architecture. In the absence of this parameter the @@ -45,20 +45,20 @@ -- Otherwise, the command name will always be of the form -- <target>-vxaddr2line where there is no ambiguity on the target's -- architecture. --- + -- <exe_file> : -- The name of the partially linked binary file for the application. --- + -- <ref_address> : -- Runtime address (on the target) of a reference symbol you choose, -- which name shall match the value of the Ref_Symbol variable declared -- below. A symbol with a small offset from the beginning of the text -- segment is better, so "adainit" is a good choice. --- + -- <backtrace addresses> : -- The call chain addresses you obtained at run time on the target and -- for which you want a symbolic association. --- + -- TO ADD A NEW ARCHITECTURE add an appropriate value to Architecture type -- (in a format <host>_<target>), and then an appropriate value to Config_List -- array @@ -75,7 +75,7 @@ with GNAT.Regpat; use GNAT.Regpat; procedure VxAddr2Line is - Ref_Symbol : String := "adainit"; + Ref_Symbol : constant String := "adainit"; -- This is the name of the reference symbol which runtime address shall -- be provided as the <ref_address> argument. @@ -171,9 +171,11 @@ procedure VxAddr2Line is ----------------- procedure Detect_Arch is - Name : String := Base_Name (Command_Name); - Proc : String := Name (Name'First .. Index (Name, "-") - 1); - Target : String := Name (Name'First .. Index (Name, "vxaddr2line") - 1); + Name : constant String := Base_Name (Command_Name); + Proc : constant String := + Name (Name'First .. Index (Name, "-") - 1); + Target : constant String := + Name (Name'First .. Index (Name, "vxaddr2line") - 1); begin Detect_Success := False; @@ -231,7 +233,7 @@ procedure VxAddr2Line is Nm_Cmd : constant String_Access := Locate_Exec_On_Path (Arch_List (Cur_Arch).Nm_Binary.all); - Nm_Args : Argument_List := + Nm_Args : constant Argument_List := (new String'("-P"), new String'(Argument (1))); @@ -260,9 +262,9 @@ procedure VxAddr2Line is -- If we are here, the pattern was matched successfully declare - Match_String : String := Expect_Out_Match (Pd); - Matches : Match_Array (0 .. 1); - Value : Integer; + Match_String : constant String := Expect_Out_Match (Pd); + Matches : Match_Array (0 .. 1); + Value : Integer; begin Match (Reference, Match_String, Matches); @@ -303,8 +305,8 @@ procedure VxAddr2Line is ---------------------------- function Get_Value_From_Hex_Arg (Arg : Natural) return Integer is + Cur_Arg : constant String := Argument (Arg); Offset : Natural; - Cur_Arg : String := Argument (Arg); begin -- Skip "0x" prefix if present diff --git a/gcc/ada/xr_tabls.adb b/gcc/ada/xr_tabls.adb index 8e332ec6..f24cbac 100644 --- a/gcc/ada/xr_tabls.adb +++ b/gcc/ada/xr_tabls.adb @@ -749,8 +749,7 @@ package body Xr_Tabls is function Get_File (Decl : Declaration_Reference; - With_Dir : Boolean := False) - return String + With_Dir : Boolean := False) return String is begin return Get_File (Decl.Decl.File, With_Dir); @@ -758,8 +757,7 @@ package body Xr_Tabls is function Get_File (Ref : Reference; - With_Dir : Boolean := False) - return String + With_Dir : Boolean := False) return String is begin return Get_File (Ref.File, With_Dir); @@ -768,8 +766,7 @@ package body Xr_Tabls is function Get_File (File : File_Reference; With_Dir : in Boolean := False; - Strip : Natural := 0) - return String + Strip : Natural := 0) return String is Tmp : GNAT.OS_Lib.String_Access; diff --git a/gcc/ada/xr_tabls.ads b/gcc/ada/xr_tabls.ads index 794dcb9..2b19944 100644 --- a/gcc/ada/xr_tabls.ads +++ b/gcc/ada/xr_tabls.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2002 Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2003 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- -- @@ -201,21 +201,19 @@ package Xr_Tabls is function Get_File (Decl : Declaration_Reference; - With_Dir : Boolean := False) - return String; + With_Dir : Boolean := False) return String; + pragma Inline (Get_File); -- Extract column number or file name from reference function Get_File (Ref : Reference; - With_Dir : Boolean := False) - return String; + With_Dir : Boolean := False) return String; pragma Inline (Get_File); function Get_File (File : File_Reference; With_Dir : Boolean := False; - Strip : Natural := 0) - return String; + Strip : Natural := 0) return String; -- Returns the file name (and its directory if With_Dir is True or the -- user has used the -f switch on the command line. If Strip is not 0, -- then the last Strip-th "-..." substrings are removed first. For @@ -223,7 +221,9 @@ package Xr_Tabls is -- would be returned as "parent-child1.ali". This is used when looking -- for the ALI file to use for a package, since for separates with have -- to use the parent's ALI. The null string is returned if there is no - -- such parent unit + -- such parent unit. + -- + -- Note that this version of Get_File is not inlined function Get_File_Ref (Ref : Reference) return File_Reference; function Get_Line (Decl : Declaration_Reference) return String; @@ -383,7 +383,6 @@ private pragma Inline (Get_Column); pragma Inline (Get_Emit_Warning); - pragma Inline (Get_File); pragma Inline (Get_File_Ref); pragma Inline (Get_Line); pragma Inline (Get_Symbol); diff --git a/gcc/ada/xref_lib.adb b/gcc/ada/xref_lib.adb index cca4285..5b953e4 100644 --- a/gcc/ada/xref_lib.adb +++ b/gcc/ada/xref_lib.adb @@ -142,7 +142,6 @@ package body Xref_Lib is Line_Num : Natural := 0; Col_Num : Natural := 0; File_Ref : File_Reference := Empty_File; - Has_Pattern : Boolean := False; begin -- Find the end of the first item in Entity (pattern or file?) @@ -224,8 +223,7 @@ package body Xref_Lib is end; end; - File_Start := File_Start + 1; - Has_Pattern := True; + File_Start := File_Start + 1; end if; -- Parse the file name @@ -291,6 +289,8 @@ package body Xref_Lib is procedure Add_Xref_File (File : String) is File_Ref : File_Reference := Empty_File; + pragma Unreferenced (File_Ref); + Iterator : Expansion_Iterator; procedure Add_Xref_File_Internal (File : String); @@ -307,7 +307,7 @@ package body Xref_Lib is if Tail (File, 4) = ".ali" then File_Ref := Add_To_Xref_File - (File, Visited => False, Emit_Warning => True); + (File, Visited => False, Emit_Warning => True); -- Normal non-ali file case @@ -315,9 +315,8 @@ package body Xref_Lib is File_Ref := Add_To_Xref_File (File, Visited => True); File_Ref := Add_To_Xref_File - (ALI_File_Name (File), - Visited => False, - Emit_Warning => True); + (ALI_File_Name (File), + Visited => False, Emit_Warning => True); end if; end Add_Xref_File_Internal; @@ -404,10 +403,12 @@ package body Xref_Lib is -------------------- procedure Find_ALI_Files is - My_Dir : Rec_DIR; - Dir_Ent : File_Name_String; - Last : Natural; - File_Ref : File_Reference; + My_Dir : Rec_DIR; + Dir_Ent : File_Name_String; + Last : Natural; + + File_Ref : File_Reference; + pragma Unreferenced (File_Ref); function Open_Next_Dir return Boolean; -- Tries to open the next object directory, and return False if @@ -568,12 +569,14 @@ package body Xref_Lib is Token : Positive; Ptr : Positive := Ali'First; Num_Dependencies : Natural := 0; - File_Ref : File_Reference; File_Start : Positive; File_End : Positive; Gnatchop_Offset : Integer; Gnatchop_Name : Positive; + File_Ref : File_Reference; + pragma Unreferenced (File_Ref); + begin -- Read all the lines possibly processing with-clauses and dependency -- information and exit on finding the first Xref line. @@ -581,7 +584,6 @@ package body Xref_Lib is -- which is an error condition. while Ali (Ptr) /= EOF loop - if D_Lines and then Ali (Ptr) = 'D' then -- Found dependency information. Format looks like: @@ -636,8 +638,8 @@ package body Xref_Lib is Parse_Token (Ali, Ptr, Token); Parse_Token (Ali, Ptr, Token); - File_Ref := Add_To_Xref_File - (Ali (Token .. Ptr - 1), Visited => False); + File_Ref := + Add_To_Xref_File (Ali (Token .. Ptr - 1), Visited => False); elsif Ali (Ptr) = 'X' then @@ -763,7 +765,6 @@ package body Xref_Lib is E_Line : Natural; -- Line number of current entity E_Col : Natural; -- Column number of current entity E_Name : Positive; -- Pointer to begin of entity name - E_Type : Character; -- Type of current entity begin -- Look for the X lines corresponding to unit Eun @@ -783,7 +784,6 @@ package body Xref_Lib is loop Parse_Number (Ali, Ptr, E_Line); - E_Type := Ali (Ptr); exit when Ali (Ptr) = EOF; Ptr := Ptr + 1; Parse_Number (Ali, Ptr, E_Col); @@ -885,7 +885,6 @@ package body Xref_Lib is Parse_Derived_Info : declare P_Line : Natural; -- parent entity line P_Column : Natural; -- parent entity column - P_Type : Character; -- parent entity type P_Eun : Positive; -- parent entity file number begin @@ -913,7 +912,6 @@ package body Xref_Lib is -- Then parse the type and column number - P_Type := Ali (Ptr); Ptr := Ptr + 1; Parse_Number (Ali, Ptr, P_Column); @@ -1034,9 +1032,9 @@ package body Xref_Lib is if Wide_Search then declare - File_Ref : File_Reference; - File_Name : constant String := - Get_Gnatchop_File (File.X_File); + File_Ref : File_Reference; + pragma Unreferenced (File_Ref); + File_Name : constant String := Get_Gnatchop_File (File.X_File); begin File_Ref := Add_To_Xref_File (ALI_File_Name (File_Name), False); end; |