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

[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
This commit is contained in:
Arnaud Charlet 2004-01-05 16:20:47 +01:00
parent 1e2d4dc105
commit 91b1417d44
137 changed files with 2503 additions and 1409 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
gcc/ada/1ssecsta.ads
View File

@ -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;

41
gcc/ada/3vexpect.adb
View File

@ -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;
-----------------

8
gcc/ada/3wsocthi.adb
View File

@ -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

82
gcc/ada/3zsocthi.adb
View File

@ -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;

18
gcc/ada/4onumaux.ads
View File

@ -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;

23
gcc/ada/4znumaux.ads
View File

@ -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;

10
gcc/ada/4zsytaco.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -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);

21
gcc/ada/56taprop.adb
View File

@ -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;

5
gcc/ada/56tpopsp.adb
View File

@ -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.

5
gcc/ada/5amastop.adb
View File

@ -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;

4
gcc/ada/5aml-tgt.adb
View File

@ -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;

19
gcc/ada/5ataprop.adb
View File

@ -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

1
gcc/ada/5atpopsp.adb
View File

@ -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);

21
gcc/ada/5ftaprop.adb
View File

@ -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

25
gcc/ada/5ginterr.adb
View File

@ -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;

19
gcc/ada/5gmastop.adb
View File

@ -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;

4
gcc/ada/5gml-tgt.adb
View File

@ -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;

7
gcc/ada/5gtaprop.adb
View File

@ -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

10
gcc/ada/5hml-tgt.adb
View File

@ -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

2
gcc/ada/5htaprop.adb
View File

@ -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;

21
gcc/ada/5htraceb.adb
View File

@ -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,

9
gcc/ada/5itaprop.adb
View File

@ -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

7
gcc/ada/5lml-tgt.adb
View File

@ -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

4
gcc/ada/5sml-tgt.adb
View File

@ -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;

12
gcc/ada/5staprop.adb
View File

@ -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

6
gcc/ada/5stpopsp.adb
View File

@ -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;

8
gcc/ada/5vasthan.adb
View File

@ -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

4
gcc/ada/5vinmaop.adb
View File

@ -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;

21
gcc/ada/5vinterr.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- 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

25
gcc/ada/5vml-tgt.adb
View File

@ -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);

60
gcc/ada/5vtaprop.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- 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);

14
gcc/ada/5wosprim.adb
View File

@ -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.

5
gcc/ada/5wtaprop.adb
View File

@ -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);

42
gcc/ada/5zinit.adb
View File

@ -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

26
gcc/ada/5zinterr.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- 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));

6
gcc/ada/5zintman.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- 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);

10
gcc/ada/5zml-tgt.adb
View File

@ -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;

3
gcc/ada/5ztaprop.adb
View File

@ -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;

72
gcc/ada/6vcpp.adb
View File

@ -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;

56
gcc/ada/6vcstrea.adb
View File

@ -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);
Ch : int;
begin
BA : constant Buffer_Access := To_BA (buffer);
Ch : int;
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);
Ch : int;
begin
BA : constant Buffer_Access := To_BA (buffer);
Ch : int;
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

2
gcc/ada/7staprop.adb
View File

@ -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;

4
gcc/ada/7stpopsp.adb
View File

@ -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);

252
gcc/ada/ChangeLog
View File

@ -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.

43
gcc/ada/Makefile.in
View File

@ -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 \

3
gcc/ada/Makefile.rtl
View File

@ -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) \

31
gcc/ada/a-numaux.ads
View File

@ -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;

70
gcc/ada/ali.adb
View File

@ -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;

64
gcc/ada/bindgen.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -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;

7
gcc/ada/bindusg.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -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");

40
gcc/ada/bld.adb
View File

@ -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

7
gcc/ada/checks.adb
View File

@ -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

17
gcc/ada/clean.adb
View File

@ -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.

4
gcc/ada/cstand.adb
View File

@ -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;

15
gcc/ada/decl.c
View File

@ -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++)

3
gcc/ada/einfo.adb
View File

@ -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);

3
gcc/ada/einfo.ads
View File

@ -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

21
gcc/ada/exp_aggr.adb
View File

@ -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.

2
gcc/ada/exp_ch11.adb
View File

@ -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);

4
gcc/ada/exp_ch3.adb
View File

@ -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);

10
gcc/ada/exp_ch4.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -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;

88
gcc/ada/exp_ch5.adb
View File

@ -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;

17
gcc/ada/exp_ch6.adb
View File

@ -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)

13
gcc/ada/exp_ch7.adb
View File

@ -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)

11
gcc/ada/exp_ch9.adb
View File

@ -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));
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

93
gcc/ada/exp_util.adb
View File

@ -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 --
----------------------------

38
gcc/ada/exp_util.ads
View File

@ -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

11
gcc/ada/fe.h
View File

@ -6,7 +6,7 @@
* *
* C Header File *
* *
* Copyright (C) 1992-2003 Free Software Foundation, Inc. *
* Copyright (C) 1992-2004 Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@ -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

35
gcc/ada/freeze.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -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

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

@ -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;

21
gcc/ada/g-dirope.adb
View File

@ -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;

9
gcc/ada/g-dirope.ads
View File

@ -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

50
gcc/ada/g-sestin.ads Normal file
View File

@ -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;

8
gcc/ada/gnat1drv.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -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

4
gcc/ada/gnatbind.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -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;

19
gcc/ada/gnatchop.adb
View File

@ -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;

13
gcc/ada/gnatfind.adb
View File

@ -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;

34
gcc/ada/gnatlbr.adb
View File

@ -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");

47
gcc/ada/gnatlink.adb
View File

@ -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

34
gcc/ada/gnatls.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -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;

30
gcc/ada/gnatmem.adb
View File

@ -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));

11
gcc/ada/gnatname.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
-- Copyright (C) 2001-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -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;
-----------

9
gcc/ada/gnatsym.adb
View File

@ -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,

28
gcc/ada/gnatxref.adb
View File

@ -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, " &

12
gcc/ada/gprcmd.adb
View File

@ -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;

19
gcc/ada/gprep.adb
View File

@ -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;

90
gcc/ada/i-cstrea.adb
View File

@ -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;

2
gcc/ada/inline.adb
View File

@ -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;

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

@ -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;

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

@ -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

8
gcc/ada/lib-xref.adb
View File

@ -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

2
gcc/ada/link.c
View File

@ -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;

98
gcc/ada/make.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -55,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;

5
gcc/ada/makeusg.adb
View File

@ -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");

68
gcc/ada/mdll.adb
View File

@ -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;

10
gcc/ada/misc.c
View File

@ -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;
}

40
gcc/ada/mlib-prj.adb
View File

@ -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;
------------------

5
gcc/ada/mlib-tgt.adb
View File

@ -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;

17
gcc/ada/opt.ads
View File

@ -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

80
gcc/ada/osint.adb
View File

@ -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

6
gcc/ada/osint.ads
View File

@ -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 --
-------------------------

Some files were not shown because too many files have changed in this diff Show More