[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:
parent
1e2d4dc105
commit
91b1417d44
|
@ -39,8 +39,8 @@ package System.Secondary_Stack is
|
||||||
|
|
||||||
package SSE renames System.Storage_Elements;
|
package SSE renames System.Storage_Elements;
|
||||||
|
|
||||||
Default_Secondary_Stack_Size : constant := 10 * 1024;
|
Default_Secondary_Stack_Size : Natural := 10 * 1024;
|
||||||
-- Default size of a secondary stack
|
-- Default size of a secondary stack. May be modified by binder -D switch
|
||||||
|
|
||||||
procedure SS_Init
|
procedure SS_Init
|
||||||
(Stk : System.Address;
|
(Stk : System.Address;
|
||||||
|
|
|
@ -102,8 +102,7 @@ package body GNAT.Expect is
|
||||||
(Fds : System.Address;
|
(Fds : System.Address;
|
||||||
Num_Fds : Integer;
|
Num_Fds : Integer;
|
||||||
Timeout : Integer;
|
Timeout : Integer;
|
||||||
Is_Set : System.Address)
|
Is_Set : System.Address) return Integer;
|
||||||
return Integer;
|
|
||||||
pragma Import (C, Poll, "__gnat_expect_poll");
|
pragma Import (C, Poll, "__gnat_expect_poll");
|
||||||
-- Check whether there is any data waiting on the file descriptor
|
-- Check whether there is any data waiting on the file descriptor
|
||||||
-- Out_fd, and wait if there is none, at most Timeout milliseconds
|
-- Out_fd, and wait if there is none, at most Timeout milliseconds
|
||||||
|
@ -130,8 +129,7 @@ package body GNAT.Expect is
|
||||||
---------
|
---------
|
||||||
|
|
||||||
function "+"
|
function "+"
|
||||||
(P : GNAT.Regpat.Pattern_Matcher)
|
(P : GNAT.Regpat.Pattern_Matcher) return Pattern_Matcher_Access
|
||||||
return Pattern_Matcher_Access
|
|
||||||
is
|
is
|
||||||
begin
|
begin
|
||||||
return new GNAT.Regpat.Pattern_Matcher'(P);
|
return new GNAT.Regpat.Pattern_Matcher'(P);
|
||||||
|
@ -768,8 +766,7 @@ package body GNAT.Expect is
|
||||||
------------------
|
------------------
|
||||||
|
|
||||||
function Get_Error_Fd
|
function Get_Error_Fd
|
||||||
(Descriptor : Process_Descriptor)
|
(Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
|
||||||
return GNAT.OS_Lib.File_Descriptor
|
|
||||||
is
|
is
|
||||||
begin
|
begin
|
||||||
return Descriptor.Error_Fd;
|
return Descriptor.Error_Fd;
|
||||||
|
@ -780,8 +777,7 @@ package body GNAT.Expect is
|
||||||
------------------
|
------------------
|
||||||
|
|
||||||
function Get_Input_Fd
|
function Get_Input_Fd
|
||||||
(Descriptor : Process_Descriptor)
|
(Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
|
||||||
return GNAT.OS_Lib.File_Descriptor
|
|
||||||
is
|
is
|
||||||
begin
|
begin
|
||||||
return Descriptor.Input_Fd;
|
return Descriptor.Input_Fd;
|
||||||
|
@ -792,8 +788,7 @@ package body GNAT.Expect is
|
||||||
-------------------
|
-------------------
|
||||||
|
|
||||||
function Get_Output_Fd
|
function Get_Output_Fd
|
||||||
(Descriptor : Process_Descriptor)
|
(Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
|
||||||
return GNAT.OS_Lib.File_Descriptor
|
|
||||||
is
|
is
|
||||||
begin
|
begin
|
||||||
return Descriptor.Output_Fd;
|
return Descriptor.Output_Fd;
|
||||||
|
@ -804,8 +799,7 @@ package body GNAT.Expect is
|
||||||
-------------
|
-------------
|
||||||
|
|
||||||
function Get_Pid
|
function Get_Pid
|
||||||
(Descriptor : Process_Descriptor)
|
(Descriptor : Process_Descriptor) return Process_Id
|
||||||
return Process_Id
|
|
||||||
is
|
is
|
||||||
begin
|
begin
|
||||||
return Descriptor.Pid;
|
return Descriptor.Pid;
|
||||||
|
@ -848,8 +842,8 @@ package body GNAT.Expect is
|
||||||
function Get_Vfork_Jmpbuf return System.Address;
|
function Get_Vfork_Jmpbuf return System.Address;
|
||||||
pragma Import (C, Get_Vfork_Jmpbuf, "decc$$get_vfork_jmpbuf");
|
pragma Import (C, Get_Vfork_Jmpbuf, "decc$$get_vfork_jmpbuf");
|
||||||
|
|
||||||
function Get_Current_Invo_Context (Addr : System.Address)
|
function Get_Current_Invo_Context
|
||||||
return Process_Id;
|
(Addr : System.Address) return Process_Id;
|
||||||
pragma Import (C, Get_Current_Invo_Context,
|
pragma Import (C, Get_Current_Invo_Context,
|
||||||
"LIB$GET_CURRENT_INVO_CONTEXT");
|
"LIB$GET_CURRENT_INVO_CONTEXT");
|
||||||
|
|
||||||
|
@ -1003,21 +997,23 @@ package body GNAT.Expect is
|
||||||
----------
|
----------
|
||||||
|
|
||||||
procedure Send
|
procedure Send
|
||||||
(Descriptor : in out Process_Descriptor;
|
(Descriptor : in out Process_Descriptor;
|
||||||
Str : String;
|
Str : String;
|
||||||
Add_LF : Boolean := True;
|
Add_LF : Boolean := True;
|
||||||
Empty_Buffer : Boolean := False)
|
Empty_Buffer : Boolean := False)
|
||||||
is
|
is
|
||||||
N : Natural;
|
|
||||||
Full_Str : constant String := Str & ASCII.LF;
|
Full_Str : constant String := Str & ASCII.LF;
|
||||||
Last : Natural;
|
Last : Natural;
|
||||||
Result : Expect_Match;
|
Result : Expect_Match;
|
||||||
Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
|
Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
|
||||||
|
|
||||||
|
Discard : Natural;
|
||||||
|
pragma Unreferenced (Discard);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if Empty_Buffer then
|
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,
|
Expect_Internal (Descriptors, Result,
|
||||||
Timeout => 0, Full_Buffer => False);
|
Timeout => 0, Full_Buffer => False);
|
||||||
|
@ -1036,9 +1032,10 @@ package body GNAT.Expect is
|
||||||
|
|
||||||
Call_Filters (Descriptor, Full_Str (Full_Str'First .. Last), Input);
|
Call_Filters (Descriptor, Full_Str (Full_Str'First .. Last), Input);
|
||||||
|
|
||||||
N := Write (Descriptor.Input_Fd,
|
Discard := Write (Descriptor.Input_Fd,
|
||||||
Full_Str'Address,
|
Full_Str'Address,
|
||||||
Last - Full_Str'First + 1);
|
Last - Full_Str'First + 1);
|
||||||
|
-- Shouldn't we at least have a pragma Assert on the result ???
|
||||||
end Send;
|
end Send;
|
||||||
|
|
||||||
-----------------
|
-----------------
|
||||||
|
|
|
@ -143,8 +143,8 @@ package body GNAT.Sockets.Thin is
|
||||||
is
|
is
|
||||||
pragma Warnings (Off, Exceptfds);
|
pragma Warnings (Off, Exceptfds);
|
||||||
|
|
||||||
RFS : Fd_Set_Access := Readfds;
|
RFS : constant Fd_Set_Access := Readfds;
|
||||||
WFS : Fd_Set_Access := Writefds;
|
WFS : constant Fd_Set_Access := Writefds;
|
||||||
WFSC : Fd_Set_Access := No_Fd_Set;
|
WFSC : Fd_Set_Access := No_Fd_Set;
|
||||||
EFS : Fd_Set_Access := Exceptfds;
|
EFS : Fd_Set_Access := Exceptfds;
|
||||||
Res : C.int;
|
Res : C.int;
|
||||||
|
@ -190,10 +190,10 @@ package body GNAT.Sockets.Thin is
|
||||||
|
|
||||||
if EFS /= No_Fd_Set then
|
if EFS /= No_Fd_Set then
|
||||||
declare
|
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;
|
Buffer : Character;
|
||||||
Length : C.int;
|
Length : C.int;
|
||||||
Flag : C.int := MSG_PEEK + MSG_OOB;
|
|
||||||
Fromlen : aliased C.int;
|
Fromlen : aliased C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
|
|
@ -45,7 +45,8 @@ with Unchecked_Conversion;
|
||||||
|
|
||||||
package body GNAT.Sockets.Thin is
|
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
|
-- When this package is initialized with Process_Blocking_IO set
|
||||||
-- to True, sockets are set in non-blocking mode to avoid blocking
|
-- to True, sockets are set in non-blocking mode to avoid blocking
|
||||||
-- the whole process when a thread wants to perform a blocking IO
|
-- 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
|
-- When Thread_Blocking_IO is False, we set sockets in
|
||||||
-- non-blocking mode and we spend a period of time Quantum between
|
-- non-blocking mode and we spend a period of time Quantum between
|
||||||
-- two attempts on a blocking operation.
|
-- two attempts on a blocking operation.
|
||||||
|
|
||||||
Thread_Blocking_IO : Boolean := True;
|
Thread_Blocking_IO : Boolean := True;
|
||||||
|
|
||||||
-- The following types and variables are required to create a Hostent
|
-- 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;
|
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);
|
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);
|
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
|
||||||
(In_Addr_Access_Array_A'First)'Access;
|
(In_Addr_Access_Array_A'First)'Access;
|
||||||
|
|
||||||
Local_Hostent : Hostent_Access := new Hostent;
|
Local_Hostent : constant Hostent_Access := new Hostent;
|
||||||
|
|
||||||
-----------------------
|
-----------------------
|
||||||
-- Local Subprograms --
|
-- Local Subprograms --
|
||||||
|
@ -87,30 +89,26 @@ package body GNAT.Sockets.Thin is
|
||||||
function Syscall_Accept
|
function Syscall_Accept
|
||||||
(S : C.int;
|
(S : C.int;
|
||||||
Addr : System.Address;
|
Addr : System.Address;
|
||||||
Addrlen : access C.int)
|
Addrlen : access C.int) return C.int;
|
||||||
return C.int;
|
|
||||||
pragma Import (C, Syscall_Accept, "accept");
|
pragma Import (C, Syscall_Accept, "accept");
|
||||||
|
|
||||||
function Syscall_Connect
|
function Syscall_Connect
|
||||||
(S : C.int;
|
(S : C.int;
|
||||||
Name : System.Address;
|
Name : System.Address;
|
||||||
Namelen : C.int)
|
Namelen : C.int) return C.int;
|
||||||
return C.int;
|
|
||||||
pragma Import (C, Syscall_Connect, "connect");
|
pragma Import (C, Syscall_Connect, "connect");
|
||||||
|
|
||||||
function Syscall_Ioctl
|
function Syscall_Ioctl
|
||||||
(S : C.int;
|
(S : C.int;
|
||||||
Req : C.int;
|
Req : C.int;
|
||||||
Arg : Int_Access)
|
Arg : Int_Access) return C.int;
|
||||||
return C.int;
|
|
||||||
pragma Import (C, Syscall_Ioctl, "ioctl");
|
pragma Import (C, Syscall_Ioctl, "ioctl");
|
||||||
|
|
||||||
function Syscall_Recv
|
function Syscall_Recv
|
||||||
(S : C.int;
|
(S : C.int;
|
||||||
Msg : System.Address;
|
Msg : System.Address;
|
||||||
Len : C.int;
|
Len : C.int;
|
||||||
Flags : C.int)
|
Flags : C.int) return C.int;
|
||||||
return C.int;
|
|
||||||
pragma Import (C, Syscall_Recv, "recv");
|
pragma Import (C, Syscall_Recv, "recv");
|
||||||
|
|
||||||
function Syscall_Recvfrom
|
function Syscall_Recvfrom
|
||||||
|
@ -119,16 +117,14 @@ package body GNAT.Sockets.Thin is
|
||||||
Len : C.int;
|
Len : C.int;
|
||||||
Flags : C.int;
|
Flags : C.int;
|
||||||
From : Sockaddr_In_Access;
|
From : Sockaddr_In_Access;
|
||||||
Fromlen : access C.int)
|
Fromlen : access C.int) return C.int;
|
||||||
return C.int;
|
|
||||||
pragma Import (C, Syscall_Recvfrom, "recvfrom");
|
pragma Import (C, Syscall_Recvfrom, "recvfrom");
|
||||||
|
|
||||||
function Syscall_Send
|
function Syscall_Send
|
||||||
(S : C.int;
|
(S : C.int;
|
||||||
Msg : System.Address;
|
Msg : System.Address;
|
||||||
Len : C.int;
|
Len : C.int;
|
||||||
Flags : C.int)
|
Flags : C.int) return C.int;
|
||||||
return C.int;
|
|
||||||
pragma Import (C, Syscall_Send, "send");
|
pragma Import (C, Syscall_Send, "send");
|
||||||
|
|
||||||
function Syscall_Sendto
|
function Syscall_Sendto
|
||||||
|
@ -137,15 +133,13 @@ package body GNAT.Sockets.Thin is
|
||||||
Len : C.int;
|
Len : C.int;
|
||||||
Flags : C.int;
|
Flags : C.int;
|
||||||
To : Sockaddr_In_Access;
|
To : Sockaddr_In_Access;
|
||||||
Tolen : C.int)
|
Tolen : C.int) return C.int;
|
||||||
return C.int;
|
|
||||||
pragma Import (C, Syscall_Sendto, "sendto");
|
pragma Import (C, Syscall_Sendto, "sendto");
|
||||||
|
|
||||||
function Syscall_Socket
|
function Syscall_Socket
|
||||||
(Domain : C.int;
|
(Domain : C.int;
|
||||||
Typ : C.int;
|
Typ : C.int;
|
||||||
Protocol : C.int)
|
Protocol : C.int) return C.int;
|
||||||
return C.int;
|
|
||||||
pragma Import (C, Syscall_Socket, "socket");
|
pragma Import (C, Syscall_Socket, "socket");
|
||||||
|
|
||||||
function Non_Blocking_Socket (S : C.int) return Boolean;
|
function Non_Blocking_Socket (S : C.int) return Boolean;
|
||||||
|
@ -158,12 +152,13 @@ package body GNAT.Sockets.Thin is
|
||||||
function C_Accept
|
function C_Accept
|
||||||
(S : C.int;
|
(S : C.int;
|
||||||
Addr : System.Address;
|
Addr : System.Address;
|
||||||
Addrlen : access C.int)
|
Addrlen : access C.int) return C.int
|
||||||
return C.int
|
|
||||||
is
|
is
|
||||||
R : C.int;
|
R : C.int;
|
||||||
Val : aliased C.int := 1;
|
Val : aliased C.int := 1;
|
||||||
|
|
||||||
Res : C.int;
|
Res : C.int;
|
||||||
|
pragma Unreferenced (Res);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
loop
|
loop
|
||||||
|
@ -184,6 +179,7 @@ package body GNAT.Sockets.Thin is
|
||||||
|
|
||||||
Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
|
Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
|
||||||
Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
|
Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
|
||||||
|
-- Is it OK to ignore result ???
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
return R;
|
return R;
|
||||||
|
@ -196,8 +192,7 @@ package body GNAT.Sockets.Thin is
|
||||||
function C_Connect
|
function C_Connect
|
||||||
(S : C.int;
|
(S : C.int;
|
||||||
Name : System.Address;
|
Name : System.Address;
|
||||||
Namelen : C.int)
|
Namelen : C.int) return C.int
|
||||||
return C.int
|
|
||||||
is
|
is
|
||||||
Res : C.int;
|
Res : C.int;
|
||||||
|
|
||||||
|
@ -260,8 +255,7 @@ package body GNAT.Sockets.Thin is
|
||||||
function C_Gethostbyaddr
|
function C_Gethostbyaddr
|
||||||
(Addr : System.Address;
|
(Addr : System.Address;
|
||||||
Len : C.int;
|
Len : C.int;
|
||||||
Typ : C.int)
|
Typ : C.int) return Hostent_Access
|
||||||
return Hostent_Access
|
|
||||||
is
|
is
|
||||||
pragma Warnings (Off, Len);
|
pragma Warnings (Off, Len);
|
||||||
pragma Warnings (Off, Typ);
|
pragma Warnings (Off, Typ);
|
||||||
|
@ -290,12 +284,10 @@ package body GNAT.Sockets.Thin is
|
||||||
---------------------
|
---------------------
|
||||||
|
|
||||||
function C_Gethostbyname
|
function C_Gethostbyname
|
||||||
(Name : C.char_array)
|
(Name : C.char_array) return Hostent_Access
|
||||||
return Hostent_Access
|
|
||||||
is
|
is
|
||||||
function VxWorks_Gethostbyname
|
function VxWorks_Gethostbyname
|
||||||
(Name : C.char_array)
|
(Name : C.char_array) return C.int;
|
||||||
return C.int;
|
|
||||||
pragma Import (C, VxWorks_Gethostbyname, "hostGetByName");
|
pragma Import (C, VxWorks_Gethostbyname, "hostGetByName");
|
||||||
|
|
||||||
Addr : C.int;
|
Addr : C.int;
|
||||||
|
@ -315,8 +307,7 @@ package body GNAT.Sockets.Thin is
|
||||||
|
|
||||||
function C_Getservbyname
|
function C_Getservbyname
|
||||||
(Name : C.char_array;
|
(Name : C.char_array;
|
||||||
Proto : C.char_array)
|
Proto : C.char_array) return Servent_Access
|
||||||
return Servent_Access
|
|
||||||
is
|
is
|
||||||
pragma Warnings (Off, Name);
|
pragma Warnings (Off, Name);
|
||||||
pragma Warnings (Off, Proto);
|
pragma Warnings (Off, Proto);
|
||||||
|
@ -331,8 +322,7 @@ package body GNAT.Sockets.Thin is
|
||||||
|
|
||||||
function C_Getservbyport
|
function C_Getservbyport
|
||||||
(Port : C.int;
|
(Port : C.int;
|
||||||
Proto : C.char_array)
|
Proto : C.char_array) return Servent_Access
|
||||||
return Servent_Access
|
|
||||||
is
|
is
|
||||||
pragma Warnings (Off, Port);
|
pragma Warnings (Off, Port);
|
||||||
pragma Warnings (Off, Proto);
|
pragma Warnings (Off, Proto);
|
||||||
|
@ -348,8 +338,7 @@ package body GNAT.Sockets.Thin is
|
||||||
function C_Ioctl
|
function C_Ioctl
|
||||||
(S : C.int;
|
(S : C.int;
|
||||||
Req : C.int;
|
Req : C.int;
|
||||||
Arg : Int_Access)
|
Arg : Int_Access) return C.int
|
||||||
return C.int
|
|
||||||
is
|
is
|
||||||
begin
|
begin
|
||||||
if not Thread_Blocking_IO
|
if not Thread_Blocking_IO
|
||||||
|
@ -371,8 +360,7 @@ package body GNAT.Sockets.Thin is
|
||||||
(S : C.int;
|
(S : C.int;
|
||||||
Msg : System.Address;
|
Msg : System.Address;
|
||||||
Len : C.int;
|
Len : C.int;
|
||||||
Flags : C.int)
|
Flags : C.int) return C.int
|
||||||
return C.int
|
|
||||||
is
|
is
|
||||||
Res : C.int;
|
Res : C.int;
|
||||||
|
|
||||||
|
@ -399,8 +387,7 @@ package body GNAT.Sockets.Thin is
|
||||||
Len : C.int;
|
Len : C.int;
|
||||||
Flags : C.int;
|
Flags : C.int;
|
||||||
From : Sockaddr_In_Access;
|
From : Sockaddr_In_Access;
|
||||||
Fromlen : access C.int)
|
Fromlen : access C.int) return C.int
|
||||||
return C.int
|
|
||||||
is
|
is
|
||||||
Res : C.int;
|
Res : C.int;
|
||||||
|
|
||||||
|
@ -425,8 +412,7 @@ package body GNAT.Sockets.Thin is
|
||||||
(S : C.int;
|
(S : C.int;
|
||||||
Msg : System.Address;
|
Msg : System.Address;
|
||||||
Len : C.int;
|
Len : C.int;
|
||||||
Flags : C.int)
|
Flags : C.int) return C.int
|
||||||
return C.int
|
|
||||||
is
|
is
|
||||||
Res : C.int;
|
Res : C.int;
|
||||||
|
|
||||||
|
@ -453,8 +439,7 @@ package body GNAT.Sockets.Thin is
|
||||||
Len : C.int;
|
Len : C.int;
|
||||||
Flags : C.int;
|
Flags : C.int;
|
||||||
To : Sockaddr_In_Access;
|
To : Sockaddr_In_Access;
|
||||||
Tolen : C.int)
|
Tolen : C.int) return C.int
|
||||||
return C.int
|
|
||||||
is
|
is
|
||||||
Res : C.int;
|
Res : C.int;
|
||||||
|
|
||||||
|
@ -478,12 +463,13 @@ package body GNAT.Sockets.Thin is
|
||||||
function C_Socket
|
function C_Socket
|
||||||
(Domain : C.int;
|
(Domain : C.int;
|
||||||
Typ : C.int;
|
Typ : C.int;
|
||||||
Protocol : C.int)
|
Protocol : C.int) return C.int
|
||||||
return C.int
|
|
||||||
is
|
is
|
||||||
R : C.int;
|
R : C.int;
|
||||||
Val : aliased C.int := 1;
|
Val : aliased C.int := 1;
|
||||||
|
|
||||||
Res : C.int;
|
Res : C.int;
|
||||||
|
pragma Unreferenced (Res);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
R := Syscall_Socket (Domain, Typ, Protocol);
|
R := Syscall_Socket (Domain, Typ, Protocol);
|
||||||
|
@ -495,6 +481,7 @@ package body GNAT.Sockets.Thin is
|
||||||
-- in non-blocking mode by user.
|
-- in non-blocking mode by user.
|
||||||
|
|
||||||
Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
|
Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
|
||||||
|
-- Is it OK to ignore result ???
|
||||||
Set_Non_Blocking_Socket (R, False);
|
Set_Non_Blocking_Socket (R, False);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
@ -611,7 +598,6 @@ package body GNAT.Sockets.Thin is
|
||||||
|
|
||||||
if C_Msg = C.Strings.Null_Ptr then
|
if C_Msg = C.Strings.Null_Ptr then
|
||||||
return "Unknown system error";
|
return "Unknown system error";
|
||||||
|
|
||||||
else
|
else
|
||||||
return C.Strings.Value (C_Msg);
|
return C.Strings.Value (C_Msg);
|
||||||
end if;
|
end if;
|
||||||
|
|
|
@ -7,7 +7,7 @@
|
||||||
-- S p e c --
|
-- S p e c --
|
||||||
-- (C Library Version for x86) --
|
-- (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 --
|
-- 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- --
|
-- 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;
|
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;
|
function Sin (X : Double) return Double;
|
||||||
pragma Import (C, Sin, "sinl");
|
pragma Import (C, Sin, "sinl");
|
||||||
|
pragma Pure_Function (Sin);
|
||||||
|
|
||||||
function Cos (X : Double) return Double;
|
function Cos (X : Double) return Double;
|
||||||
pragma Import (C, Cos, "cosl");
|
pragma Import (C, Cos, "cosl");
|
||||||
|
pragma Pure_Function (Cos);
|
||||||
|
|
||||||
function Tan (X : Double) return Double;
|
function Tan (X : Double) return Double;
|
||||||
pragma Import (C, Tan, "tanl");
|
pragma Import (C, Tan, "tanl");
|
||||||
|
pragma Pure_Function (Tan);
|
||||||
|
|
||||||
function Exp (X : Double) return Double;
|
function Exp (X : Double) return Double;
|
||||||
pragma Import (C, Exp, "expl");
|
pragma Import (C, Exp, "expl");
|
||||||
|
pragma Pure_Function (Exp);
|
||||||
|
|
||||||
function Sqrt (X : Double) return Double;
|
function Sqrt (X : Double) return Double;
|
||||||
pragma Import (C, Sqrt, "sqrtl");
|
pragma Import (C, Sqrt, "sqrtl");
|
||||||
|
pragma Pure_Function (Sqrt);
|
||||||
|
|
||||||
function Log (X : Double) return Double;
|
function Log (X : Double) return Double;
|
||||||
pragma Import (C, Log, "logl");
|
pragma Import (C, Log, "logl");
|
||||||
|
pragma Pure_Function (Log);
|
||||||
|
|
||||||
function Acos (X : Double) return Double;
|
function Acos (X : Double) return Double;
|
||||||
pragma Import (C, Acos, "acosl");
|
pragma Import (C, Acos, "acosl");
|
||||||
|
pragma Pure_Function (Acos);
|
||||||
|
|
||||||
function Asin (X : Double) return Double;
|
function Asin (X : Double) return Double;
|
||||||
pragma Import (C, Asin, "asinl");
|
pragma Import (C, Asin, "asinl");
|
||||||
|
pragma Pure_Function (Asin);
|
||||||
|
|
||||||
function Atan (X : Double) return Double;
|
function Atan (X : Double) return Double;
|
||||||
pragma Import (C, Atan, "atanl");
|
pragma Import (C, Atan, "atanl");
|
||||||
|
pragma Pure_Function (Atan);
|
||||||
|
|
||||||
function Sinh (X : Double) return Double;
|
function Sinh (X : Double) return Double;
|
||||||
pragma Import (C, Sinh, "sinhl");
|
pragma Import (C, Sinh, "sinhl");
|
||||||
|
pragma Pure_Function (Sinh);
|
||||||
|
|
||||||
function Cosh (X : Double) return Double;
|
function Cosh (X : Double) return Double;
|
||||||
pragma Import (C, Cosh, "coshl");
|
pragma Import (C, Cosh, "coshl");
|
||||||
|
pragma Pure_Function (Cosh);
|
||||||
|
|
||||||
function Tanh (X : Double) return Double;
|
function Tanh (X : Double) return Double;
|
||||||
pragma Import (C, Tanh, "tanhl");
|
pragma Import (C, Tanh, "tanhl");
|
||||||
|
pragma Pure_Function (Tanh);
|
||||||
|
|
||||||
function Pow (X, Y : Double) return Double;
|
function Pow (X, Y : Double) return Double;
|
||||||
pragma Import (C, Pow, "powl");
|
pragma Import (C, Pow, "powl");
|
||||||
|
pragma Pure_Function (Pow);
|
||||||
|
|
||||||
end Ada.Numerics.Aux;
|
end Ada.Numerics.Aux;
|
||||||
|
|
|
@ -7,7 +7,7 @@
|
||||||
-- S p e c --
|
-- S p e c --
|
||||||
-- (C Library Version, VxWorks) --
|
-- (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 --
|
-- 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- --
|
-- 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.
|
-- no libm.a library for VxWorks.
|
||||||
|
|
||||||
type Double is digits 15;
|
type Double is digits 15;
|
||||||
pragma Float_Representation (IEEE_Float, Double);
|
-- Type Double is the type used to call the C routines
|
||||||
-- 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
|
-- We import these functions directly from C. Note that we label them
|
||||||
-- since we use the IEEE version of the C library with VMS.
|
-- all as pure functions, because indeed all of them are in fact pure!
|
||||||
|
|
||||||
function Sin (X : Double) return Double;
|
function Sin (X : Double) return Double;
|
||||||
pragma Import (C, Sin, "sin");
|
pragma Import (C, Sin, "sin");
|
||||||
|
pragma Pure_Function (Sin);
|
||||||
|
|
||||||
function Cos (X : Double) return Double;
|
function Cos (X : Double) return Double;
|
||||||
pragma Import (C, Cos, "cos");
|
pragma Import (C, Cos, "cos");
|
||||||
|
pragma Pure_Function (Cos);
|
||||||
|
|
||||||
function Tan (X : Double) return Double;
|
function Tan (X : Double) return Double;
|
||||||
pragma Import (C, Tan, "tan");
|
pragma Import (C, Tan, "tan");
|
||||||
|
pragma Pure_Function (Tan);
|
||||||
|
|
||||||
function Exp (X : Double) return Double;
|
function Exp (X : Double) return Double;
|
||||||
pragma Import (C, Exp, "exp");
|
pragma Import (C, Exp, "exp");
|
||||||
|
pragma Pure_Function (Exp);
|
||||||
|
|
||||||
function Sqrt (X : Double) return Double;
|
function Sqrt (X : Double) return Double;
|
||||||
pragma Import (C, Sqrt, "sqrt");
|
pragma Import (C, Sqrt, "sqrt");
|
||||||
|
pragma Pure_Function (Sqrt);
|
||||||
|
|
||||||
function Log (X : Double) return Double;
|
function Log (X : Double) return Double;
|
||||||
pragma Import (C, Log, "log");
|
pragma Import (C, Log, "log");
|
||||||
|
pragma Pure_Function (Log);
|
||||||
|
|
||||||
function Acos (X : Double) return Double;
|
function Acos (X : Double) return Double;
|
||||||
pragma Import (C, Acos, "acos");
|
pragma Import (C, Acos, "acos");
|
||||||
|
pragma Pure_Function (Acos);
|
||||||
|
|
||||||
function Asin (X : Double) return Double;
|
function Asin (X : Double) return Double;
|
||||||
pragma Import (C, Asin, "asin");
|
pragma Import (C, Asin, "asin");
|
||||||
|
pragma Pure_Function (Asin);
|
||||||
|
|
||||||
function Atan (X : Double) return Double;
|
function Atan (X : Double) return Double;
|
||||||
pragma Import (C, Atan, "atan");
|
pragma Import (C, Atan, "atan");
|
||||||
|
pragma Pure_Function (Atan);
|
||||||
|
|
||||||
function Sinh (X : Double) return Double;
|
function Sinh (X : Double) return Double;
|
||||||
pragma Import (C, Sinh, "sinh");
|
pragma Import (C, Sinh, "sinh");
|
||||||
|
pragma Pure_Function (Sinh);
|
||||||
|
|
||||||
function Cosh (X : Double) return Double;
|
function Cosh (X : Double) return Double;
|
||||||
pragma Import (C, Cosh, "cosh");
|
pragma Import (C, Cosh, "cosh");
|
||||||
|
pragma Pure_Function (Cosh);
|
||||||
|
|
||||||
function Tanh (X : Double) return Double;
|
function Tanh (X : Double) return Double;
|
||||||
pragma Import (C, Tanh, "tanh");
|
pragma Import (C, Tanh, "tanh");
|
||||||
|
pragma Pure_Function (Tanh);
|
||||||
|
|
||||||
function Pow (X, Y : Double) return Double;
|
function Pow (X, Y : Double) return Double;
|
||||||
pragma Import (C, Pow, "pow");
|
pragma Import (C, Pow, "pow");
|
||||||
|
pragma Pure_Function (Pow);
|
||||||
|
|
||||||
end Ada.Numerics.Aux;
|
end Ada.Numerics.Aux;
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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);
|
St := semTake (S.Sema, NO_WAIT);
|
||||||
|
|
||||||
|
-- If we took the semaphore, reset semaphore state to FULL
|
||||||
|
|
||||||
if St = OK then
|
if St = OK then
|
||||||
-- Took the semaphore. Reset semaphore state to FULL
|
|
||||||
Result := True;
|
Result := True;
|
||||||
St := semGive (S.Sema);
|
St := semGive (S.Sema);
|
||||||
end if;
|
end if;
|
||||||
|
@ -74,6 +75,7 @@ package body Ada.Synchronous_Task_Control is
|
||||||
-- empty (St = OK) or have left it empty.
|
-- empty (St = OK) or have left it empty.
|
||||||
|
|
||||||
St := semTake (S.Sema, NO_WAIT);
|
St := semTake (S.Sema, NO_WAIT);
|
||||||
|
pragma Assert (St = OK);
|
||||||
end Set_False;
|
end Set_False;
|
||||||
|
|
||||||
--------------
|
--------------
|
||||||
|
@ -82,7 +84,7 @@ package body Ada.Synchronous_Task_Control is
|
||||||
|
|
||||||
procedure Set_True (S : in out Suspension_Object) is
|
procedure Set_True (S : in out Suspension_Object) is
|
||||||
St : STATUS;
|
St : STATUS;
|
||||||
|
pragma Unreferenced (St);
|
||||||
begin
|
begin
|
||||||
St := semGive (S.Sema);
|
St := semGive (S.Sema);
|
||||||
end Set_True;
|
end Set_True;
|
||||||
|
@ -136,7 +138,7 @@ package body Ada.Synchronous_Task_Control is
|
||||||
|
|
||||||
procedure Finalize (S : in out Suspension_Object) is
|
procedure Finalize (S : in out Suspension_Object) is
|
||||||
St : STATUS;
|
St : STATUS;
|
||||||
|
pragma Unreferenced (St);
|
||||||
begin
|
begin
|
||||||
St := semDelete (S.Sema);
|
St := semDelete (S.Sema);
|
||||||
St := semDelete (S.Mutex);
|
St := semDelete (S.Mutex);
|
||||||
|
|
|
@ -332,7 +332,6 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
procedure Finalize_Lock (L : access Lock) is
|
procedure Finalize_Lock (L : access Lock) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result := pthread_mutex_destroy (L.Mutex'Access);
|
Result := pthread_mutex_destroy (L.Mutex'Access);
|
||||||
pragma Assert (Result = 0);
|
pragma Assert (Result = 0);
|
||||||
|
@ -340,7 +339,6 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
procedure Finalize_Lock (L : access RTS_Lock) is
|
procedure Finalize_Lock (L : access RTS_Lock) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result := pthread_mutex_destroy (L);
|
Result := pthread_mutex_destroy (L);
|
||||||
pragma Assert (Result = 0);
|
pragma Assert (Result = 0);
|
||||||
|
@ -382,7 +380,6 @@ package body System.Task_Primitives.Operations is
|
||||||
(L : access RTS_Lock; Global_Lock : Boolean := False)
|
(L : access RTS_Lock; Global_Lock : Boolean := False)
|
||||||
is
|
is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if not Single_Lock or else Global_Lock then
|
if not Single_Lock or else Global_Lock then
|
||||||
Result := pthread_mutex_lock (L);
|
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
|
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if not Single_Lock or else Global_Lock then
|
if not Single_Lock or else Global_Lock then
|
||||||
Result := pthread_mutex_unlock (L);
|
Result := pthread_mutex_unlock (L);
|
||||||
|
@ -439,7 +435,6 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
procedure Unlock (T : Task_ID) is
|
procedure Unlock (T : Task_ID) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if not Single_Lock then
|
if not Single_Lock then
|
||||||
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
|
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)
|
Reason : System.Tasking.Task_States)
|
||||||
is
|
is
|
||||||
pragma Unreferenced (Reason);
|
pragma Unreferenced (Reason);
|
||||||
|
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
@ -468,7 +462,7 @@ package body System.Task_Primitives.Operations is
|
||||||
(Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
|
(Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- EINTR is not considered a failure.
|
-- EINTR is not considered a failure
|
||||||
|
|
||||||
pragma Assert (Result = 0 or else Result = EINTR);
|
pragma Assert (Result = 0 or else Result = EINTR);
|
||||||
end Sleep;
|
end Sleep;
|
||||||
|
@ -654,7 +648,6 @@ package body System.Task_Primitives.Operations is
|
||||||
function Monotonic_Clock return Duration is
|
function Monotonic_Clock return Duration is
|
||||||
TS : aliased timespec;
|
TS : aliased timespec;
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result := clock_gettime
|
Result := clock_gettime
|
||||||
(clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access);
|
(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
|
function RT_Resolution return Duration is
|
||||||
Res : aliased timespec;
|
Res : aliased timespec;
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result := clock_getres
|
Result := clock_getres
|
||||||
(clock_id => CLOCK_REALTIME, Res => Res'Unchecked_Access);
|
(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
|
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
|
||||||
pragma Unreferenced (Reason);
|
pragma Unreferenced (Reason);
|
||||||
|
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result := pthread_cond_signal (T.Common.LL.CV'Access);
|
Result := pthread_cond_signal (T.Common.LL.CV'Access);
|
||||||
pragma Assert (Result = 0);
|
pragma Assert (Result = 0);
|
||||||
|
@ -697,7 +687,7 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
procedure Yield (Do_Yield : Boolean := True) is
|
procedure Yield (Do_Yield : Boolean := True) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
pragma Unreferenced (Result);
|
||||||
begin
|
begin
|
||||||
if Do_Yield then
|
if Do_Yield then
|
||||||
Result := sched_yield;
|
Result := sched_yield;
|
||||||
|
@ -923,6 +913,7 @@ package body System.Task_Primitives.Operations is
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
if Stack_Base_Available then
|
if Stack_Base_Available then
|
||||||
|
|
||||||
-- If Stack Checking is supported then allocate 2 additional pages:
|
-- If Stack Checking is supported then allocate 2 additional pages:
|
||||||
--
|
--
|
||||||
-- In the worst case, stack is allocated at something like
|
-- 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
|
procedure Abort_Task (T : Task_ID) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result := pthread_kill (T.Common.LL.Thread,
|
Result := pthread_kill (T.Common.LL.Thread,
|
||||||
Signal (System.Interrupt_Management.Abort_Task_Interrupt));
|
Signal (System.Interrupt_Management.Abort_Task_Interrupt));
|
||||||
|
@ -1095,7 +1085,6 @@ package body System.Task_Primitives.Operations is
|
||||||
is
|
is
|
||||||
pragma Unreferenced (T);
|
pragma Unreferenced (T);
|
||||||
pragma Unreferenced (Thread_Self);
|
pragma Unreferenced (Thread_Self);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
return False;
|
return False;
|
||||||
end Suspend_Task;
|
end Suspend_Task;
|
||||||
|
@ -1106,12 +1095,10 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
function Resume_Task
|
function Resume_Task
|
||||||
(T : ST.Task_ID;
|
(T : ST.Task_ID;
|
||||||
Thread_Self : Thread_Id)
|
Thread_Self : Thread_Id) return Boolean
|
||||||
return Boolean
|
|
||||||
is
|
is
|
||||||
pragma Unreferenced (T);
|
pragma Unreferenced (T);
|
||||||
pragma Unreferenced (Thread_Self);
|
pragma Unreferenced (Thread_Self);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
return False;
|
return False;
|
||||||
end Resume_Task;
|
end Resume_Task;
|
||||||
|
|
|
@ -92,11 +92,14 @@ package body Specific is
|
||||||
-- tasks.
|
-- tasks.
|
||||||
|
|
||||||
function Self return Task_ID is
|
function Self return Task_ID is
|
||||||
Result : Interfaces.C.int;
|
|
||||||
Value : aliased System.Address;
|
Value : aliased System.Address;
|
||||||
|
|
||||||
|
Result : Interfaces.C.int;
|
||||||
|
pragma Unreferenced (Result);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result := st_getspecific (ATCB_Key, Value'Address);
|
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.
|
-- If the key value is Null, then it is a non-Ada task.
|
||||||
|
|
||||||
|
|
|
@ -7,7 +7,7 @@
|
||||||
-- B o d y --
|
-- B o d y --
|
||||||
-- (Version for Alpha/Dec Unix) --
|
-- (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 --
|
-- 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- --
|
-- 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
|
-- asm instruction takes 4 bytes. So we must remove this value from
|
||||||
-- c_get_code_loc to have the call point.
|
-- 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
|
begin
|
||||||
if Loc = 0 then
|
if Loc = 0 then
|
||||||
return 0;
|
return 0;
|
||||||
|
|
|
@ -189,7 +189,9 @@ package body MLib.Tgt is
|
||||||
Success : Boolean;
|
Success : Boolean;
|
||||||
Oldpath : String (1 .. Lib_Version'Length + 1);
|
Oldpath : String (1 .. Lib_Version'Length + 1);
|
||||||
Newpath : String (1 .. Lib_File'Length + 1);
|
Newpath : String (1 .. Lib_File'Length + 1);
|
||||||
Result : Integer;
|
|
||||||
|
Result : Integer;
|
||||||
|
pragma Unreferenced (Result);
|
||||||
|
|
||||||
function Symlink
|
function Symlink
|
||||||
(Oldpath : System.Address;
|
(Oldpath : System.Address;
|
||||||
|
|
|
@ -626,9 +626,7 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
|
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
|
||||||
pragma Unreferenced (Reason);
|
pragma Unreferenced (Reason);
|
||||||
|
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result := pthread_cond_signal (T.Common.LL.CV'Access);
|
Result := pthread_cond_signal (T.Common.LL.CV'Access);
|
||||||
pragma Assert (Result = 0);
|
pragma Assert (Result = 0);
|
||||||
|
@ -640,6 +638,7 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
procedure Yield (Do_Yield : Boolean := True) is
|
procedure Yield (Do_Yield : Boolean := True) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
pragma Unreferenced (Result);
|
||||||
begin
|
begin
|
||||||
if Do_Yield then
|
if Do_Yield then
|
||||||
Result := sched_yield;
|
Result := sched_yield;
|
||||||
|
@ -972,7 +971,6 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
procedure Abort_Task (T : Task_ID) is
|
procedure Abort_Task (T : Task_ID) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result :=
|
Result :=
|
||||||
pthread_kill
|
pthread_kill
|
||||||
|
@ -1038,8 +1036,7 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
function Suspend_Task
|
function Suspend_Task
|
||||||
(T : ST.Task_ID;
|
(T : ST.Task_ID;
|
||||||
Thread_Self : Thread_Id)
|
Thread_Self : Thread_Id) return Boolean
|
||||||
return Boolean
|
|
||||||
is
|
is
|
||||||
pragma Warnings (Off, T);
|
pragma Warnings (Off, T);
|
||||||
pragma Warnings (Off, Thread_Self);
|
pragma Warnings (Off, Thread_Self);
|
||||||
|
@ -1054,8 +1051,7 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
function Resume_Task
|
function Resume_Task
|
||||||
(T : ST.Task_ID;
|
(T : ST.Task_ID;
|
||||||
Thread_Self : Thread_Id)
|
Thread_Self : Thread_Id) return Boolean
|
||||||
return Boolean
|
|
||||||
is
|
is
|
||||||
pragma Warnings (Off, T);
|
pragma Warnings (Off, T);
|
||||||
pragma Warnings (Off, Thread_Self);
|
pragma Warnings (Off, Thread_Self);
|
||||||
|
@ -1074,12 +1070,11 @@ package body System.Task_Primitives.Operations is
|
||||||
Tmp_Set : aliased sigset_t;
|
Tmp_Set : aliased sigset_t;
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
function State (Int : System.Interrupt_Management.Interrupt_ID)
|
function State
|
||||||
return Character;
|
(Int : System.Interrupt_Management.Interrupt_ID) return Character;
|
||||||
pragma Import (C, State, "__gnat_get_interrupt_state");
|
pragma Import (C, State, "__gnat_get_interrupt_state");
|
||||||
-- Get interrupt state. Defined in a-init.c
|
-- Get interrupt state. Defined in a-init.c. The input argument is
|
||||||
-- The input argument is the interrupt number,
|
-- the interrupt number, and the result is one of the following:
|
||||||
-- and the result is one of the following:
|
|
||||||
|
|
||||||
Default : constant Character := 's';
|
Default : constant Character := 's';
|
||||||
-- 'n' this interrupt not set by any Interrupt_State pragma
|
-- 'n' this interrupt not set by any Interrupt_State pragma
|
||||||
|
|
|
@ -68,7 +68,6 @@ package body Specific is
|
||||||
|
|
||||||
procedure Set (Self_Id : Task_ID) is
|
procedure Set (Self_Id : Task_ID) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id));
|
Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id));
|
||||||
pragma Assert (Result = 0);
|
pragma Assert (Result = 0);
|
||||||
|
|
|
@ -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
|
-- This package contains all the GNULL primitives that interface directly
|
||||||
-- with the underlying OS.
|
-- 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
|
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
|
||||||
pragma Unreferenced (On);
|
pragma Unreferenced (On);
|
||||||
pragma Unreferenced (T);
|
pragma Unreferenced (T);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
null;
|
null;
|
||||||
end Stack_Guard;
|
end Stack_Guard;
|
||||||
|
@ -332,7 +331,6 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
procedure Finalize_Lock (L : access Lock) is
|
procedure Finalize_Lock (L : access Lock) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result := pthread_mutex_destroy (L);
|
Result := pthread_mutex_destroy (L);
|
||||||
pragma Assert (Result = 0);
|
pragma Assert (Result = 0);
|
||||||
|
@ -340,7 +338,6 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
procedure Finalize_Lock (L : access RTS_Lock) is
|
procedure Finalize_Lock (L : access RTS_Lock) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result := pthread_mutex_destroy (L);
|
Result := pthread_mutex_destroy (L);
|
||||||
pragma Assert (Result = 0);
|
pragma Assert (Result = 0);
|
||||||
|
@ -356,13 +353,14 @@ package body System.Task_Primitives.Operations is
|
||||||
Result := pthread_mutex_lock (L);
|
Result := pthread_mutex_lock (L);
|
||||||
Ceiling_Violation := Result = EINVAL;
|
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);
|
pragma Assert (Result = 0 or else Result = EINVAL);
|
||||||
end Write_Lock;
|
end Write_Lock;
|
||||||
|
|
||||||
procedure Write_Lock
|
procedure Write_Lock
|
||||||
(L : access RTS_Lock; Global_Lock : Boolean := False)
|
(L : access RTS_Lock;
|
||||||
|
Global_Lock : Boolean := False)
|
||||||
is
|
is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
begin
|
begin
|
||||||
|
@ -396,7 +394,6 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
procedure Unlock (L : access Lock) is
|
procedure Unlock (L : access Lock) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result := pthread_mutex_unlock (L);
|
Result := pthread_mutex_unlock (L);
|
||||||
pragma Assert (Result = 0);
|
pragma Assert (Result = 0);
|
||||||
|
@ -584,7 +581,6 @@ package body System.Task_Primitives.Operations is
|
||||||
function Monotonic_Clock return Duration is
|
function Monotonic_Clock return Duration is
|
||||||
TS : aliased timespec;
|
TS : aliased timespec;
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result := clock_gettime (Real_Time_Clock_Id, TS'Unchecked_Access);
|
Result := clock_gettime (Real_Time_Clock_Id, TS'Unchecked_Access);
|
||||||
pragma Assert (Result = 0);
|
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
|
procedure Wakeup (T : ST.Task_ID; Reason : System.Tasking.Task_States) is
|
||||||
pragma Unreferenced (Reason);
|
pragma Unreferenced (Reason);
|
||||||
|
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result := pthread_cond_signal (T.Common.LL.CV'Access);
|
Result := pthread_cond_signal (T.Common.LL.CV'Access);
|
||||||
pragma Assert (Result = 0);
|
pragma Assert (Result = 0);
|
||||||
|
@ -628,7 +622,7 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
procedure Yield (Do_Yield : Boolean := True) is
|
procedure Yield (Do_Yield : Boolean := True) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
pragma Unreferenced (Result);
|
||||||
begin
|
begin
|
||||||
if Do_Yield then
|
if Do_Yield then
|
||||||
Result := sched_yield;
|
Result := sched_yield;
|
||||||
|
@ -1069,9 +1063,8 @@ package body System.Task_Primitives.Operations is
|
||||||
function State (Int : System.Interrupt_Management.Interrupt_ID)
|
function State (Int : System.Interrupt_Management.Interrupt_ID)
|
||||||
return Character;
|
return Character;
|
||||||
pragma Import (C, State, "__gnat_get_interrupt_state");
|
pragma Import (C, State, "__gnat_get_interrupt_state");
|
||||||
-- Get interrupt state. Defined in a-init.c
|
-- Get interrupt state. Defined in a-init.c. The input argument is
|
||||||
-- The input argument is the interrupt number,
|
-- the interrupt number, and the result is one of the following:
|
||||||
-- and the result is one of the following:
|
|
||||||
|
|
||||||
Default : constant Character := 's';
|
Default : constant Character := 's';
|
||||||
-- 'n' this interrupt not set by any Interrupt_State pragma
|
-- 'n' this interrupt not set by any Interrupt_State pragma
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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
|
function Has_Interrupt_Or_Attach_Handler
|
||||||
(Object : access Dynamic_Interrupt_Protection)
|
(Object : access Dynamic_Interrupt_Protection) return Boolean
|
||||||
return Boolean
|
|
||||||
is
|
is
|
||||||
pragma Unreferenced (Object);
|
pragma Unreferenced (Object);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
return True;
|
return True;
|
||||||
end Has_Interrupt_Or_Attach_Handler;
|
end Has_Interrupt_Or_Attach_Handler;
|
||||||
|
@ -279,11 +277,9 @@ package body System.Interrupts is
|
||||||
-------------------------------------
|
-------------------------------------
|
||||||
|
|
||||||
function Has_Interrupt_Or_Attach_Handler
|
function Has_Interrupt_Or_Attach_Handler
|
||||||
(Object : access Static_Interrupt_Protection)
|
(Object : access Static_Interrupt_Protection) return Boolean
|
||||||
return Boolean
|
|
||||||
is
|
is
|
||||||
pragma Unreferenced (Object);
|
pragma Unreferenced (Object);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
return True;
|
return True;
|
||||||
end Has_Interrupt_Or_Attach_Handler;
|
end Has_Interrupt_Or_Attach_Handler;
|
||||||
|
@ -320,8 +316,9 @@ package body System.Interrupts is
|
||||||
-- Current_Handler --
|
-- Current_Handler --
|
||||||
---------------------
|
---------------------
|
||||||
|
|
||||||
function Current_Handler (Interrupt : Interrupt_ID)
|
function Current_Handler
|
||||||
return Parameterless_Handler is
|
(Interrupt : Interrupt_ID) return Parameterless_Handler
|
||||||
|
is
|
||||||
begin
|
begin
|
||||||
if Is_Reserved (Interrupt) then
|
if Is_Reserved (Interrupt) then
|
||||||
raise Program_Error;
|
raise Program_Error;
|
||||||
|
@ -466,13 +463,15 @@ package body System.Interrupts is
|
||||||
---------------
|
---------------
|
||||||
|
|
||||||
function Reference (Interrupt : Interrupt_ID) return System.Address is
|
function Reference (Interrupt : Interrupt_ID) return System.Address is
|
||||||
Signal : System.Address :=
|
Signal : constant System.Address :=
|
||||||
System.Storage_Elements.To_Address
|
System.Storage_Elements.To_Address
|
||||||
(System.Storage_Elements.Integer_Address (Interrupt));
|
(System.Storage_Elements.Integer_Address (Interrupt));
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if Is_Reserved (Interrupt) then
|
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;
|
raise Program_Error;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
|
|
@ -108,18 +108,20 @@ package body System.Machine_State_Operations is
|
||||||
-- ABI-Dependent Declarations --
|
-- ABI-Dependent Declarations --
|
||||||
--------------------------------
|
--------------------------------
|
||||||
|
|
||||||
o32 : constant Natural := Boolean'Pos (System.Word_Size = 32);
|
o32 : constant Boolean := System.Word_Size = 32;
|
||||||
n32 : constant Natural := Boolean'Pos (System.Word_Size = 64);
|
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
|
-- 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.
|
-- purposes of this unit, the n32 and n64 ABI's are identical.
|
||||||
|
|
||||||
LSC : constant Character := Character'Val (o32 * Character'Pos ('w') +
|
LSC : constant Character := Character'Val (o32n * Character'Pos ('w') +
|
||||||
n32 * Character'Pos ('d'));
|
n32n * Character'Pos ('d'));
|
||||||
-- This is 'w' for o32, and 'd' for n32/n64, used for constructing the
|
-- This is 'w' for o32, and 'd' for n32/n64, used for constructing the
|
||||||
-- load/store instructions used to save/restore machine instructions.
|
-- load/store instructions used to save/restore machine instructions.
|
||||||
|
|
||||||
Roff : constant Character := Character'Val (o32 * Character'Pos ('4') +
|
Roff : constant Character := Character'Val (o32n * Character'Pos ('4') +
|
||||||
n32 * Character'Pos (' '));
|
n32n * Character'Pos (' '));
|
||||||
-- Offset from first byte of a __uint64 register save location where
|
-- Offset from first byte of a __uint64 register save location where
|
||||||
-- the register value is stored. For n32/64 we store the entire 64
|
-- 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
|
-- 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
|
function To_I_Type_Ptr is new
|
||||||
Unchecked_Conversion (Address_Int, I_Type_Ptr);
|
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;
|
GP_Ptr : Uns32_Ptr;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
@ -311,12 +313,11 @@ package body System.Machine_State_Operations is
|
||||||
Scp.SC_PC := 0;
|
Scp.SC_PC := 0;
|
||||||
|
|
||||||
else
|
else
|
||||||
|
|
||||||
-- Set the GP to restore to the caller value (not callee value)
|
-- 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
|
-- This is done only in o32 mode. In n32/n64 mode, GP is a normal
|
||||||
-- callee save register
|
-- callee save register
|
||||||
|
|
||||||
if o32 = 1 then
|
if o32 then
|
||||||
Update_GP (Scp);
|
Update_GP (Scp);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
|
|
@ -172,7 +172,9 @@ package body MLib.Tgt is
|
||||||
Success : Boolean;
|
Success : Boolean;
|
||||||
Oldpath : String (1 .. Lib_Version'Length + 1);
|
Oldpath : String (1 .. Lib_Version'Length + 1);
|
||||||
Newpath : String (1 .. Lib_File'Length + 1);
|
Newpath : String (1 .. Lib_File'Length + 1);
|
||||||
Result : Integer;
|
|
||||||
|
Result : Integer;
|
||||||
|
pragma Unreferenced (Result);
|
||||||
|
|
||||||
function Symlink
|
function Symlink
|
||||||
(Oldpath : System.Address;
|
(Oldpath : System.Address;
|
||||||
|
|
|
@ -534,7 +534,6 @@ package body System.Task_Primitives.Operations is
|
||||||
Reason : System.Tasking.Task_States)
|
Reason : System.Tasking.Task_States)
|
||||||
is
|
is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result := pthread_cond_signal (T.Common.LL.CV'Access);
|
Result := pthread_cond_signal (T.Common.LL.CV'Access);
|
||||||
pragma Assert (Result = 0);
|
pragma Assert (Result = 0);
|
||||||
|
@ -878,8 +877,7 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
function Suspend_Task
|
function Suspend_Task
|
||||||
(T : ST.Task_ID;
|
(T : ST.Task_ID;
|
||||||
Thread_Self : Thread_Id)
|
Thread_Self : Thread_Id) return Boolean
|
||||||
return Boolean
|
|
||||||
is
|
is
|
||||||
begin
|
begin
|
||||||
if T.Common.LL.Thread /= Thread_Self then
|
if T.Common.LL.Thread /= Thread_Self then
|
||||||
|
@ -895,8 +893,7 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
function Resume_Task
|
function Resume_Task
|
||||||
(T : ST.Task_ID;
|
(T : ST.Task_ID;
|
||||||
Thread_Self : Thread_Id)
|
Thread_Self : Thread_Id) return Boolean
|
||||||
return Boolean
|
|
||||||
is
|
is
|
||||||
begin
|
begin
|
||||||
if T.Common.LL.Thread /= Thread_Self then
|
if T.Common.LL.Thread /= Thread_Self then
|
||||||
|
|
|
@ -125,7 +125,8 @@ package body MLib.Tgt is
|
||||||
|
|
||||||
Init_Fini : Argument_List_Access := Empty_Argument_List;
|
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.
|
-- Common set of options to the gcc command performing the link.
|
||||||
-- On HPUX, this command eventually resorts to collect2, which may
|
-- On HPUX, this command eventually resorts to collect2, which may
|
||||||
-- generate a C file and compile it on the fly. This compilation shall
|
-- generate a C file and compile it on the fly. This compilation shall
|
||||||
|
@ -177,12 +178,13 @@ package body MLib.Tgt is
|
||||||
Success : Boolean;
|
Success : Boolean;
|
||||||
Oldpath : String (1 .. Lib_Version'Length + 1);
|
Oldpath : String (1 .. Lib_Version'Length + 1);
|
||||||
Newpath : String (1 .. Lib_File'Length + 1);
|
Newpath : String (1 .. Lib_File'Length + 1);
|
||||||
Result : Integer;
|
|
||||||
|
Result : Integer;
|
||||||
|
pragma Unreferenced (Result);
|
||||||
|
|
||||||
function Symlink
|
function Symlink
|
||||||
(Oldpath : System.Address;
|
(Oldpath : System.Address;
|
||||||
Newpath : System.Address)
|
Newpath : System.Address) return Integer;
|
||||||
return Integer;
|
|
||||||
pragma Import (C, Symlink, "__gnat_symlink");
|
pragma Import (C, Symlink, "__gnat_symlink");
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
|
|
@ -600,7 +600,7 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
procedure Yield (Do_Yield : Boolean := True) is
|
procedure Yield (Do_Yield : Boolean := True) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
pragma Unreferenced (Result);
|
||||||
begin
|
begin
|
||||||
if Do_Yield then
|
if Do_Yield then
|
||||||
Result := sched_yield;
|
Result := sched_yield;
|
||||||
|
|
|
@ -221,8 +221,7 @@ package body System.Traceback is
|
||||||
(Pc : Address;
|
(Pc : Address;
|
||||||
Space : Address;
|
Space : Address;
|
||||||
Table_Start : Address;
|
Table_Start : Address;
|
||||||
Table_End : Address)
|
Table_End : Address) return Address;
|
||||||
return Address;
|
|
||||||
pragma Import (C, U_get_unwind_entry, "U_get_unwind_entry");
|
pragma Import (C, U_get_unwind_entry, "U_get_unwind_entry");
|
||||||
-- Given the bounds of an unwind table, return the address of the
|
-- Given the bounds of an unwind table, return the address of the
|
||||||
-- unwind descriptor associated with a code location/space. In the case
|
-- 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
|
function U_get_previous_frame_x
|
||||||
(current_frame : access CFD;
|
(current_frame : access CFD;
|
||||||
previous_frame : access PFD;
|
previous_frame : access PFD;
|
||||||
previous_size : Integer)
|
previous_size : Integer) return Integer;
|
||||||
return Integer;
|
|
||||||
pragma Import (C, U_get_previous_frame_x, "U_get_previous_frame_x");
|
pragma Import (C, U_get_previous_frame_x, "U_get_previous_frame_x");
|
||||||
-- Fetch the data describing the "previous" frame relatively to the
|
-- Fetch the data describing the "previous" frame relatively to the
|
||||||
-- "current" one. "previous_size" should be the size of the "previous"
|
-- "current" one. "previous_size" should be the size of the "previous"
|
||||||
|
@ -270,9 +268,8 @@ package body System.Traceback is
|
||||||
------------------
|
------------------
|
||||||
|
|
||||||
function C_Call_Chain
|
function C_Call_Chain
|
||||||
(Traceback : System.Address;
|
(Traceback : System.Address;
|
||||||
Max_Len : Natural)
|
Max_Len : Natural) return Natural
|
||||||
return Natural
|
|
||||||
is
|
is
|
||||||
Val : Natural;
|
Val : Natural;
|
||||||
|
|
||||||
|
@ -530,10 +527,12 @@ package body System.Traceback is
|
||||||
and then U_is_shared_pc (Frame.cur_rlo, Frame.cur_r19) /= 0
|
and then U_is_shared_pc (Frame.cur_rlo, Frame.cur_r19) /= 0
|
||||||
then
|
then
|
||||||
declare
|
declare
|
||||||
Shlib_UWT : UWT := U_get_shLib_unwind_table (Frame.cur_r19);
|
Shlib_UWT : constant UWT :=
|
||||||
Shlib_Start : Address := U_get_shLib_text_addr (Frame.cur_r19);
|
U_get_shLib_unwind_table (Frame.cur_r19);
|
||||||
Rlo_Offset : Address := Frame.cur_rlo - Shlib_Start;
|
Shlib_Start : constant Address :=
|
||||||
|
U_get_shLib_text_addr (Frame.cur_r19);
|
||||||
|
Rlo_Offset : constant Address :=
|
||||||
|
Frame.cur_rlo - Shlib_Start;
|
||||||
begin
|
begin
|
||||||
UWD_Address := U_get_unwind_entry (Rlo_Offset,
|
UWD_Address := U_get_unwind_entry (Rlo_Offset,
|
||||||
Frame.cur_rls,
|
Frame.cur_rls,
|
||||||
|
|
|
@ -656,9 +656,7 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
|
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
|
||||||
pragma Unreferenced (Reason);
|
pragma Unreferenced (Reason);
|
||||||
|
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result := pthread_cond_signal (T.Common.LL.CV'Access);
|
Result := pthread_cond_signal (T.Common.LL.CV'Access);
|
||||||
pragma Assert (Result = 0);
|
pragma Assert (Result = 0);
|
||||||
|
@ -671,7 +669,6 @@ package body System.Task_Primitives.Operations is
|
||||||
procedure Yield (Do_Yield : Boolean := True) is
|
procedure Yield (Do_Yield : Boolean := True) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
pragma Unreferenced (Result);
|
pragma Unreferenced (Result);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if Do_Yield then
|
if Do_Yield then
|
||||||
Result := sched_yield;
|
Result := sched_yield;
|
||||||
|
@ -988,8 +985,7 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
function Suspend_Task
|
function Suspend_Task
|
||||||
(T : ST.Task_ID;
|
(T : ST.Task_ID;
|
||||||
Thread_Self : Thread_Id)
|
Thread_Self : Thread_Id) return Boolean
|
||||||
return Boolean
|
|
||||||
is
|
is
|
||||||
begin
|
begin
|
||||||
if T.Common.LL.Thread /= Thread_Self then
|
if T.Common.LL.Thread /= Thread_Self then
|
||||||
|
@ -1005,8 +1001,7 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
function Resume_Task
|
function Resume_Task
|
||||||
(T : ST.Task_ID;
|
(T : ST.Task_ID;
|
||||||
Thread_Self : Thread_Id)
|
Thread_Self : Thread_Id) return Boolean
|
||||||
return Boolean
|
|
||||||
is
|
is
|
||||||
begin
|
begin
|
||||||
if T.Common.LL.Thread /= Thread_Self then
|
if T.Common.LL.Thread /= Thread_Self then
|
||||||
|
|
|
@ -175,12 +175,13 @@ package body MLib.Tgt is
|
||||||
Success : Boolean;
|
Success : Boolean;
|
||||||
Oldpath : String (1 .. Lib_Version'Length + 1);
|
Oldpath : String (1 .. Lib_Version'Length + 1);
|
||||||
Newpath : String (1 .. Lib_File'Length + 1);
|
Newpath : String (1 .. Lib_File'Length + 1);
|
||||||
Result : Integer;
|
|
||||||
|
Result : Integer;
|
||||||
|
pragma Unreferenced (Result);
|
||||||
|
|
||||||
function Symlink
|
function Symlink
|
||||||
(Oldpath : System.Address;
|
(Oldpath : System.Address;
|
||||||
Newpath : System.Address)
|
Newpath : System.Address) return Integer;
|
||||||
return Integer;
|
|
||||||
pragma Import (C, Symlink, "__gnat_symlink");
|
pragma Import (C, Symlink, "__gnat_symlink");
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
|
|
@ -171,7 +171,9 @@ package body MLib.Tgt is
|
||||||
Success : Boolean;
|
Success : Boolean;
|
||||||
Oldpath : String (1 .. Lib_Version'Length + 1);
|
Oldpath : String (1 .. Lib_Version'Length + 1);
|
||||||
Newpath : String (1 .. Lib_File'Length + 1);
|
Newpath : String (1 .. Lib_File'Length + 1);
|
||||||
Result : Integer;
|
|
||||||
|
Result : Integer;
|
||||||
|
pragma Unreferenced (Result);
|
||||||
|
|
||||||
function Symlink
|
function Symlink
|
||||||
(Oldpath : System.Address;
|
(Oldpath : System.Address;
|
||||||
|
|
|
@ -275,14 +275,11 @@ package body System.Task_Primitives.Operations is
|
||||||
------------
|
------------
|
||||||
|
|
||||||
Check_Count : Integer := 0;
|
Check_Count : Integer := 0;
|
||||||
Old_Owner : Task_ID;
|
|
||||||
Lock_Count : Integer := 0;
|
Lock_Count : Integer := 0;
|
||||||
Unlock_Count : Integer := 0;
|
Unlock_Count : Integer := 0;
|
||||||
|
|
||||||
function To_Lock_Ptr is
|
function To_Lock_Ptr is
|
||||||
new Unchecked_Conversion (RTS_Lock_Ptr, Lock_Ptr);
|
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
|
function To_Owner_ID is
|
||||||
new Unchecked_Conversion (Task_ID, Owner_ID);
|
new Unchecked_Conversion (Task_ID, Owner_ID);
|
||||||
|
|
||||||
|
@ -300,9 +297,11 @@ package body System.Task_Primitives.Operations is
|
||||||
pragma Unreferenced (Context);
|
pragma Unreferenced (Context);
|
||||||
|
|
||||||
Self_ID : Task_ID := Self;
|
Self_ID : Task_ID := Self;
|
||||||
Result : Interfaces.C.int;
|
|
||||||
Old_Set : aliased sigset_t;
|
Old_Set : aliased sigset_t;
|
||||||
|
|
||||||
|
Result : Interfaces.C.int;
|
||||||
|
pragma Unreferenced (Result);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
-- It is not safe to raise an exception when using ZCX and the GCC
|
-- It is not safe to raise an exception when using ZCX and the GCC
|
||||||
-- exception handling mechanism.
|
-- exception handling mechanism.
|
||||||
|
@ -758,7 +757,9 @@ package body System.Task_Primitives.Operations is
|
||||||
is
|
is
|
||||||
pragma Unreferenced (Loss_Of_Inheritance);
|
pragma Unreferenced (Loss_Of_Inheritance);
|
||||||
|
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
pragma Unreferenced (Result);
|
||||||
|
|
||||||
Param : aliased struct_pcparms;
|
Param : aliased struct_pcparms;
|
||||||
|
|
||||||
use Task_Info;
|
use Task_Info;
|
||||||
|
@ -1605,7 +1606,6 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
if Unlock_Count - Check_Count > 1000 then
|
if Unlock_Count - Check_Count > 1000 then
|
||||||
Check_Count := Unlock_Count;
|
Check_Count := Unlock_Count;
|
||||||
Old_Owner := To_Task_ID (Single_RTS_Lock.Owner);
|
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- Check that caller is abort-deferred
|
-- Check that caller is abort-deferred
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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)
|
separate (System.Task_Primitives.Operations)
|
||||||
package body Specific is
|
package body Specific is
|
||||||
|
@ -54,11 +54,9 @@ package body Specific is
|
||||||
function Is_Valid_Task return Boolean is
|
function Is_Valid_Task return Boolean is
|
||||||
Unknown_Task : aliased System.Address;
|
Unknown_Task : aliased System.Address;
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result := thr_getspecific (ATCB_Key, Unknown_Task'Unchecked_Access);
|
Result := thr_getspecific (ATCB_Key, Unknown_Task'Unchecked_Access);
|
||||||
pragma Assert (Result = 0);
|
pragma Assert (Result = 0);
|
||||||
|
|
||||||
return Unknown_Task /= System.Null_Address;
|
return Unknown_Task /= System.Null_Address;
|
||||||
end Is_Valid_Task;
|
end Is_Valid_Task;
|
||||||
|
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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
|
procedure Allocate_New_AST_Server is
|
||||||
Dummy : AST_Server_Task_Ptr;
|
Dummy : AST_Server_Task_Ptr;
|
||||||
|
pragma Unreferenced (Dummy);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if Num_AST_Servers = Max_AST_Servers then
|
if Num_AST_Servers = Max_AST_Servers then
|
||||||
|
@ -454,8 +455,7 @@ package body System.AST_Handling is
|
||||||
|
|
||||||
function Create_AST_Handler
|
function Create_AST_Handler
|
||||||
(Taskid : ATID.Task_Id;
|
(Taskid : ATID.Task_Id;
|
||||||
Entryno : Natural)
|
Entryno : Natural) return System.Aux_DEC.AST_Handler
|
||||||
return System.Aux_DEC.AST_Handler
|
|
||||||
is
|
is
|
||||||
Attr_Ref : Attribute_Handle;
|
Attr_Ref : Attribute_Handle;
|
||||||
|
|
||||||
|
@ -465,7 +465,7 @@ package body System.AST_Handling is
|
||||||
function To_Descriptor_Ref is new Ada.Unchecked_Conversion
|
function To_Descriptor_Ref is new Ada.Unchecked_Conversion
|
||||||
(AST_Handler, Descriptor_Ref);
|
(AST_Handler, Descriptor_Ref);
|
||||||
|
|
||||||
Original_Descriptor_Ref : Descriptor_Ref :=
|
Original_Descriptor_Ref : constant Descriptor_Ref :=
|
||||||
To_Descriptor_Ref (Process_AST_Ptr);
|
To_Descriptor_Ref (Process_AST_Ptr);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
|
|
@ -7,7 +7,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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)
|
function Interrupt_Wait (Mask : access Interrupt_Mask)
|
||||||
return Interrupt_ID
|
return Interrupt_ID
|
||||||
is
|
is
|
||||||
Self_ID : Task_ID := Self;
|
Self_ID : constant Task_ID := Self;
|
||||||
Iosb : IO_Status_Block_Type := (0, 0, 0);
|
Iosb : IO_Status_Block_Type := (0, 0, 0);
|
||||||
Status : Cond_Value_Type;
|
Status : Cond_Value_Type;
|
||||||
|
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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);
|
pragma Volatile_Components (User_Entry);
|
||||||
-- Holds the task and entry index (if any) for each interrupt
|
-- Holds the task and entry index (if any) for each interrupt
|
||||||
|
|
||||||
Blocked : array (Interrupt_ID'Range) of Boolean := (others => False);
|
Blocked : constant array (Interrupt_ID'Range) of Boolean :=
|
||||||
pragma Volatile_Components (Blocked);
|
(others => False);
|
||||||
|
-- ??? pragma Volatile_Components (Blocked);
|
||||||
-- True iff the corresponding interrupt is blocked in the process level
|
-- True iff the corresponding interrupt is blocked in the process level
|
||||||
|
|
||||||
Ignored : array (Interrupt_ID'Range) of Boolean := (others => False);
|
Ignored : array (Interrupt_ID'Range) of Boolean := (others => False);
|
||||||
pragma Volatile_Components (Ignored);
|
pragma Volatile_Components (Ignored);
|
||||||
-- True iff the corresponding interrupt is blocked in the process level
|
-- True iff the corresponding interrupt is blocked in the process level
|
||||||
|
|
||||||
Last_Unblocker :
|
Last_Unblocker : constant array (Interrupt_ID'Range) of Task_ID :=
|
||||||
array (Interrupt_ID'Range) of Task_ID := (others => Null_Task);
|
(others => Null_Task);
|
||||||
pragma Volatile_Components (Last_Unblocker);
|
-- ??? pragma Volatile_Components (Last_Unblocker);
|
||||||
-- Holds the ID of the last Task which Unblocked this Interrupt.
|
-- Holds the ID of the last Task which Unblocked this Interrupt.
|
||||||
-- It contains Null_Task if no tasks have ever requested the
|
-- It contains Null_Task if no tasks have ever requested the
|
||||||
-- Unblocking operation or the Interrupt is currently Blocked.
|
-- Unblocking operation or the Interrupt is currently Blocked.
|
||||||
|
@ -324,7 +325,7 @@ package body System.Interrupts is
|
||||||
|
|
||||||
Ptr := Registered_Handler_Head;
|
Ptr := Registered_Handler_Head;
|
||||||
|
|
||||||
while (Ptr /= null) loop
|
while Ptr /= null loop
|
||||||
if Ptr.H = Fat.Handler_Addr then
|
if Ptr.H = Fat.Handler_Addr then
|
||||||
return True;
|
return True;
|
||||||
end if;
|
end if;
|
||||||
|
@ -726,8 +727,6 @@ package body System.Interrupts is
|
||||||
(Interrupt : Interrupt_ID;
|
(Interrupt : Interrupt_ID;
|
||||||
Static : Boolean)
|
Static : Boolean)
|
||||||
is
|
is
|
||||||
Old_Handler : Parameterless_Handler;
|
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if User_Entry (Interrupt).T /= Null_Task then
|
if User_Entry (Interrupt).T /= Null_Task then
|
||||||
-- In case we have an Interrupt Entry installed.
|
-- In case we have an Interrupt Entry installed.
|
||||||
|
@ -754,8 +753,6 @@ package body System.Interrupts is
|
||||||
|
|
||||||
Ignored (Interrupt) := False;
|
Ignored (Interrupt) := False;
|
||||||
|
|
||||||
Old_Handler := User_Handler (Interrupt).H;
|
|
||||||
|
|
||||||
-- The new handler
|
-- The new handler
|
||||||
|
|
||||||
User_Handler (Interrupt).H := null;
|
User_Handler (Interrupt).H := null;
|
||||||
|
@ -959,7 +956,6 @@ package body System.Interrupts is
|
||||||
Tmp_ID : Task_ID;
|
Tmp_ID : Task_ID;
|
||||||
Tmp_Entry_Index : Task_Entry_Index;
|
Tmp_Entry_Index : Task_Entry_Index;
|
||||||
Intwait_Mask : aliased IMNG.Interrupt_Mask;
|
Intwait_Mask : aliased IMNG.Interrupt_Mask;
|
||||||
Ret_Interrupt : IMNG.Interrupt_ID;
|
|
||||||
|
|
||||||
begin
|
begin
|
||||||
-- By making this task independent of master, when the process
|
-- By making this task independent of master, when the process
|
||||||
|
@ -1016,7 +1012,6 @@ package body System.Interrupts is
|
||||||
|
|
||||||
else
|
else
|
||||||
Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag;
|
Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag;
|
||||||
Ret_Interrupt := IMOP.Interrupt_Wait (Intwait_Mask'Access);
|
|
||||||
Self_ID.Common.State := Runnable;
|
Self_ID.Common.State := Runnable;
|
||||||
|
|
||||||
if not (Self_ID.Deferral_Level = 0
|
if not (Self_ID.Deferral_Level = 0
|
||||||
|
|
|
@ -7,7 +7,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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
|
-- This is the VMS version of the body
|
||||||
-- static, dynamic and shared libraries.
|
|
||||||
|
|
||||||
-- This is the VMS version of the body.
|
|
||||||
|
|
||||||
with Ada.Characters.Handling; use Ada.Characters.Handling;
|
with Ada.Characters.Handling; use Ada.Characters.Handling;
|
||||||
with Ada.Text_IO; use Ada.Text_IO;
|
with Ada.Text_IO; use Ada.Text_IO;
|
||||||
|
@ -142,8 +139,6 @@ package body MLib.Tgt is
|
||||||
pragma Unreferenced (Lib_Address);
|
pragma Unreferenced (Lib_Address);
|
||||||
pragma Unreferenced (Relocatable);
|
pragma Unreferenced (Relocatable);
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
Lib_File : constant String :=
|
Lib_File : constant String :=
|
||||||
Lib_Dir & Directory_Separator & "lib" &
|
Lib_Dir & Directory_Separator & "lib" &
|
||||||
Fil.Ext_To (Lib_Filename, DLL_Ext);
|
Fil.Ext_To (Lib_Filename, DLL_Ext);
|
||||||
|
@ -152,7 +147,8 @@ package body MLib.Tgt is
|
||||||
Last_Opt : Natural := Opts'Last;
|
Last_Opt : Natural := Opts'Last;
|
||||||
Opts2 : Argument_List (Options'Range);
|
Opts2 : Argument_List (Options'Range);
|
||||||
Last_Opt2 : Natural := Opts2'First - 1;
|
Last_Opt2 : Natural := Opts2'First - 1;
|
||||||
Inter : Argument_List := Interfaces;
|
|
||||||
|
Inter : constant Argument_List := Interfaces;
|
||||||
|
|
||||||
function Is_Interface (Obj_File : String) return Boolean;
|
function Is_Interface (Obj_File : String) return Boolean;
|
||||||
-- For a Stand-Alone Library, returns True if Obj_File is the object
|
-- 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
|
function Is_Interface (Obj_File : String) return Boolean is
|
||||||
ALI : constant String :=
|
ALI : constant String :=
|
||||||
Fil.Ext_To
|
Fil.Ext_To
|
||||||
(Filename => To_Lower (Base_Name (Obj_File)),
|
(Filename => To_Lower (Base_Name (Obj_File)),
|
||||||
New_Ext => "ali");
|
New_Ext => "ali");
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if Inter'Length = 0 then
|
if Inter'Length = 0 then
|
||||||
return True;
|
return True;
|
||||||
|
@ -203,7 +200,6 @@ package body MLib.Tgt is
|
||||||
begin
|
begin
|
||||||
if Symbol_Data.Symbol_File = No_Name then
|
if Symbol_Data.Symbol_File = No_Name then
|
||||||
return "symvec.opt";
|
return "symvec.opt";
|
||||||
|
|
||||||
else
|
else
|
||||||
return Get_Name_String (Symbol_Data.Symbol_File);
|
return Get_Name_String (Symbol_Data.Symbol_File);
|
||||||
end if;
|
end if;
|
||||||
|
@ -239,9 +235,11 @@ package body MLib.Tgt is
|
||||||
end Version_String;
|
end Version_String;
|
||||||
|
|
||||||
Opt_File_Name : constant String := Option_File_Name;
|
Opt_File_Name : constant String := Option_File_Name;
|
||||||
|
Version : constant String := Version_String;
|
||||||
For_Linker_Opt : constant String_Access :=
|
For_Linker_Opt : constant String_Access :=
|
||||||
new String'("--for-linker=" & Opt_File_Name);
|
new String'("--for-linker=" & Opt_File_Name);
|
||||||
Version : constant String := Version_String;
|
|
||||||
|
-- Start of processing for Build_Dynamic_Library
|
||||||
|
|
||||||
begin
|
begin
|
||||||
VMS_Options (VMS_Options'First + 1) := For_Linker_Opt;
|
VMS_Options (VMS_Options'First + 1) := For_Linker_Opt;
|
||||||
|
@ -423,6 +421,7 @@ package body MLib.Tgt is
|
||||||
declare
|
declare
|
||||||
Index : Natural := Opts'First;
|
Index : Natural := Opts'First;
|
||||||
Opt : String_Access;
|
Opt : String_Access;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
while Index <= Last_Opt loop
|
while Index <= Last_Opt loop
|
||||||
Opt := Opts (Index);
|
Opt := Opts (Index);
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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);
|
procedure Set (Self_Id : Task_ID);
|
||||||
pragma Inline (Set);
|
pragma Inline (Set);
|
||||||
-- Set the self id for the current task.
|
-- Set the self id for the current task
|
||||||
|
|
||||||
function Self return Task_ID;
|
function Self return Task_ID;
|
||||||
pragma Inline (Self);
|
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;
|
end Specific;
|
||||||
|
|
||||||
|
@ -143,7 +143,7 @@ package body System.Task_Primitives.Operations is
|
||||||
---------------------------------
|
---------------------------------
|
||||||
|
|
||||||
function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
|
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
|
function Register_Foreign_Thread
|
||||||
(Thread : Thread_Id) return Task_ID is separate;
|
(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.
|
-- Signal the condition variable when AST fires.
|
||||||
|
|
||||||
procedure Timer_Sleep_AST (ID : Address) is
|
procedure Timer_Sleep_AST (ID : Address) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
Self_ID : Task_ID := To_Task_ID (ID);
|
Self_ID : Task_ID := To_Task_ID (ID);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Self_ID.Common.LL.AST_Pending := False;
|
Self_ID.Common.LL.AST_Pending := False;
|
||||||
Result := pthread_cond_signal_int_np (Self_ID.Common.LL.CV'Access);
|
Result := pthread_cond_signal_int_np (Self_ID.Common.LL.CV'Access);
|
||||||
|
pragma Assert (Result = 0);
|
||||||
end Timer_Sleep_AST;
|
end Timer_Sleep_AST;
|
||||||
|
|
||||||
-------------------
|
-----------------
|
||||||
-- Stack_Guard --
|
-- Stack_Guard --
|
||||||
-------------------
|
-----------------
|
||||||
|
|
||||||
-- The underlying thread system sets a guard page at the
|
-- The underlying thread system sets a guard page at the
|
||||||
-- bottom of a thread stack, so nothing is needed.
|
-- 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
|
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
|
||||||
pragma Unreferenced (T);
|
pragma Unreferenced (T);
|
||||||
pragma Unreferenced (On);
|
pragma Unreferenced (On);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
null;
|
null;
|
||||||
end Stack_Guard;
|
end Stack_Guard;
|
||||||
|
@ -281,7 +280,6 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
procedure Finalize_Lock (L : access Lock) is
|
procedure Finalize_Lock (L : access Lock) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result := pthread_mutex_destroy (L.L'Access);
|
Result := pthread_mutex_destroy (L.L'Access);
|
||||||
pragma Assert (Result = 0);
|
pragma Assert (Result = 0);
|
||||||
|
@ -289,7 +287,6 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
procedure Finalize_Lock (L : access RTS_Lock) is
|
procedure Finalize_Lock (L : access RTS_Lock) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result := pthread_mutex_destroy (L);
|
Result := pthread_mutex_destroy (L);
|
||||||
pragma Assert (Result = 0);
|
pragma Assert (Result = 0);
|
||||||
|
@ -308,7 +305,7 @@ package body System.Task_Primitives.Operations is
|
||||||
begin
|
begin
|
||||||
Current_Prio := Get_Priority (Self_ID);
|
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
|
if All_Tasks_Link /= Null_Task
|
||||||
and then L.Prio < Interfaces.C.int (Current_Prio)
|
and then L.Prio < Interfaces.C.int (Current_Prio)
|
||||||
|
@ -331,7 +328,6 @@ package body System.Task_Primitives.Operations is
|
||||||
Global_Lock : Boolean := False)
|
Global_Lock : Boolean := False)
|
||||||
is
|
is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if not Single_Lock or else Global_Lock then
|
if not Single_Lock or else Global_Lock then
|
||||||
Result := pthread_mutex_lock (L);
|
Result := pthread_mutex_lock (L);
|
||||||
|
@ -341,7 +337,6 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
procedure Write_Lock (T : Task_ID) is
|
procedure Write_Lock (T : Task_ID) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if not Single_Lock then
|
if not Single_Lock then
|
||||||
Result := pthread_mutex_lock (T.Common.LL.L'Access);
|
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
|
procedure Unlock (L : access Lock) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result := pthread_mutex_unlock (L.L'Access);
|
Result := pthread_mutex_unlock (L.L'Access);
|
||||||
pragma Assert (Result = 0);
|
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
|
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if not Single_Lock or else Global_Lock then
|
if not Single_Lock or else Global_Lock then
|
||||||
Result := pthread_mutex_unlock (L);
|
Result := pthread_mutex_unlock (L);
|
||||||
|
@ -382,7 +375,6 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
procedure Unlock (T : Task_ID) is
|
procedure Unlock (T : Task_ID) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if not Single_Lock then
|
if not Single_Lock then
|
||||||
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
|
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);
|
(Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- EINTR is not considered a failure.
|
-- EINTR is not considered a failure
|
||||||
|
|
||||||
pragma Assert (Result = 0 or else Result = EINTR);
|
pragma Assert (Result = 0 or else Result = EINTR);
|
||||||
|
|
||||||
|
@ -440,6 +432,8 @@ package body System.Task_Primitives.Operations is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
Status : Cond_Value_Type;
|
Status : Cond_Value_Type;
|
||||||
|
|
||||||
|
-- The body below requires more comments ???
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Timedout := False;
|
Timedout := False;
|
||||||
Yielded := False;
|
Yielded := False;
|
||||||
|
@ -465,10 +459,12 @@ package body System.Task_Primitives.Operations is
|
||||||
if Single_Lock then
|
if Single_Lock then
|
||||||
Result := pthread_cond_wait
|
Result := pthread_cond_wait
|
||||||
(Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
|
(Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
|
||||||
|
pragma Assert (Result = 0);
|
||||||
|
|
||||||
else
|
else
|
||||||
Result := pthread_cond_wait
|
Result := pthread_cond_wait
|
||||||
(Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
|
(Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
|
||||||
|
pragma Assert (Result = 0);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
Yielded := True;
|
Yielded := True;
|
||||||
|
@ -504,6 +500,8 @@ package body System.Task_Primitives.Operations is
|
||||||
Lock_RTS;
|
Lock_RTS;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
-- More comments required in body below ???
|
||||||
|
|
||||||
SSL.Abort_Defer.all;
|
SSL.Abort_Defer.all;
|
||||||
Write_Lock (Self_ID);
|
Write_Lock (Self_ID);
|
||||||
|
|
||||||
|
@ -538,9 +536,11 @@ package body System.Task_Primitives.Operations is
|
||||||
if Single_Lock then
|
if Single_Lock then
|
||||||
Result := pthread_cond_wait
|
Result := pthread_cond_wait
|
||||||
(Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
|
(Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
|
||||||
|
pragma Assert (Result = 0);
|
||||||
else
|
else
|
||||||
Result := pthread_cond_wait
|
Result := pthread_cond_wait
|
||||||
(Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
|
(Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
|
||||||
|
pragma Assert (Result = 0);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
Yielded := True;
|
Yielded := True;
|
||||||
|
@ -560,6 +560,7 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
if not Yielded then
|
if not Yielded then
|
||||||
Result := sched_yield;
|
Result := sched_yield;
|
||||||
|
pragma Assert (Result = 0);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
SSL.Abort_Undefer.all;
|
SSL.Abort_Undefer.all;
|
||||||
|
@ -601,7 +602,7 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
procedure Yield (Do_Yield : Boolean := True) is
|
procedure Yield (Do_Yield : Boolean := True) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
pragma Unreferenced (Result);
|
||||||
begin
|
begin
|
||||||
if Do_Yield then
|
if Do_Yield then
|
||||||
Result := sched_yield;
|
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
|
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
|
||||||
Mutex_Attr : aliased pthread_mutexattr_t;
|
Mutex_Attr : aliased pthread_mutexattr_t;
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
Cond_Attr : aliased pthread_condattr_t;
|
Cond_Attr : aliased pthread_condattr_t;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
-- More comments required in body below ???
|
||||||
|
|
||||||
if not Single_Lock then
|
if not Single_Lock then
|
||||||
Result := pthread_mutexattr_init (Mutex_Attr'Access);
|
Result := pthread_mutexattr_init (Mutex_Attr'Access);
|
||||||
pragma Assert (Result = 0 or else Result = ENOMEM);
|
pragma Assert (Result = 0 or else Result = ENOMEM);
|
||||||
|
@ -960,8 +963,7 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
function Suspend_Task
|
function Suspend_Task
|
||||||
(T : ST.Task_ID;
|
(T : ST.Task_ID;
|
||||||
Thread_Self : Thread_Id)
|
Thread_Self : Thread_Id) return Boolean
|
||||||
return Boolean
|
|
||||||
is
|
is
|
||||||
pragma Unreferenced (T);
|
pragma Unreferenced (T);
|
||||||
pragma Unreferenced (Thread_Self);
|
pragma Unreferenced (Thread_Self);
|
||||||
|
@ -976,12 +978,10 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
function Resume_Task
|
function Resume_Task
|
||||||
(T : ST.Task_ID;
|
(T : ST.Task_ID;
|
||||||
Thread_Self : Thread_Id)
|
Thread_Self : Thread_Id) return Boolean
|
||||||
return Boolean
|
|
||||||
is
|
is
|
||||||
pragma Unreferenced (T);
|
pragma Unreferenced (T);
|
||||||
pragma Unreferenced (Thread_Self);
|
pragma Unreferenced (Thread_Self);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
return False;
|
return False;
|
||||||
end Resume_Task;
|
end Resume_Task;
|
||||||
|
@ -994,7 +994,7 @@ package body System.Task_Primitives.Operations is
|
||||||
begin
|
begin
|
||||||
Environment_Task_ID := Environment_Task;
|
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);
|
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
|
||||||
|
|
||||||
|
|
|
@ -93,28 +93,28 @@ package body System.OS_Primitives is
|
||||||
-- Use to have indirect access to multi-word variables
|
-- Use to have indirect access to multi-word variables
|
||||||
|
|
||||||
Tick_Frequency : aliased LARGE_INTEGER;
|
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
|
-- Holds frequency of high-performance counter used by Clock
|
||||||
-- Windows NT uses a 1_193_182 Hz counter on PCs.
|
-- Windows NT uses a 1_193_182 Hz counter on PCs.
|
||||||
|
|
||||||
Base_Ticks : aliased LARGE_INTEGER;
|
Base_Ticks : aliased LARGE_INTEGER;
|
||||||
BTA : LIA := Base_Ticks'Access;
|
BTA : constant LIA := Base_Ticks'Access;
|
||||||
-- Holds the Tick count for the base time.
|
-- Holds the Tick count for the base time.
|
||||||
|
|
||||||
Base_Monotonic_Ticks : aliased LARGE_INTEGER;
|
Base_Monotonic_Ticks : aliased LARGE_INTEGER;
|
||||||
BMTA : LIA := Base_Monotonic_Ticks'Access;
|
BMTA : constant LIA := Base_Monotonic_Ticks'Access;
|
||||||
-- Holds the Tick count for the base monotonic time.
|
-- Holds the Tick count for the base monotonic time
|
||||||
|
|
||||||
Base_Clock : aliased Duration;
|
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
|
-- Holds the current clock for the standard clock's base time
|
||||||
|
|
||||||
Base_Monotonic_Clock : aliased Duration;
|
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
|
-- Holds the current clock for monotonic clock's base time
|
||||||
|
|
||||||
Base_Time : aliased Long_Long_Integer;
|
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
|
-- Holds the base time used to check for system time change, used with
|
||||||
-- the standard clock.
|
-- the standard clock.
|
||||||
|
|
||||||
|
|
|
@ -1012,7 +1012,8 @@ package body System.Task_Primitives.Operations is
|
||||||
----------------
|
----------------
|
||||||
|
|
||||||
procedure Initialize (Environment_Task : Task_ID) is
|
procedure Initialize (Environment_Task : Task_ID) is
|
||||||
Res : BOOL;
|
Discard : BOOL;
|
||||||
|
pragma Unreferenced (Discard);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Environment_Task_ID := Environment_Task;
|
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
|
-- Here we need Annex E semantics, switch the current process to the
|
||||||
-- High_Priority_Class.
|
-- High_Priority_Class.
|
||||||
|
|
||||||
Res :=
|
Discard :=
|
||||||
OS_Interface.SetPriorityClass
|
OS_Interface.SetPriorityClass
|
||||||
(GetCurrentProcess, High_Priority_Class);
|
(GetCurrentProcess, High_Priority_Class);
|
||||||
|
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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;
|
with Interfaces.C;
|
||||||
-- used for int and other types
|
-- Used for int and other types
|
||||||
|
|
||||||
with Ada.Exceptions;
|
with Ada.Exceptions;
|
||||||
-- used for Raise_Exception
|
-- Used for Raise_Exception
|
||||||
|
|
||||||
package body System.Init is
|
package body System.Init is
|
||||||
|
|
||||||
-- This unit contains initialization circuits that are system dependent.
|
|
||||||
|
|
||||||
use Ada.Exceptions;
|
use Ada.Exceptions;
|
||||||
use Interfaces.C;
|
use Interfaces.C;
|
||||||
|
|
||||||
|
@ -52,6 +50,7 @@ package body System.Init is
|
||||||
|
|
||||||
NSIG : constant := 32;
|
NSIG : constant := 32;
|
||||||
-- Number of signals on the target OS
|
-- Number of signals on the target OS
|
||||||
|
|
||||||
type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1);
|
type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1);
|
||||||
|
|
||||||
SIGILL : constant := 4; -- illegal instruction (not reset)
|
SIGILL : constant := 4; -- illegal instruction (not reset)
|
||||||
|
@ -137,9 +136,9 @@ package body System.Init is
|
||||||
Already_Called : Boolean := False;
|
Already_Called : Boolean := False;
|
||||||
|
|
||||||
Handler_Installed : Integer := 0;
|
Handler_Installed : Integer := 0;
|
||||||
|
pragma Export (C, Handler_Installed, "__gnat_handler_installed");
|
||||||
-- Indication of whether synchronous signal handlers have already been
|
-- Indication of whether synchronous signal handlers have already been
|
||||||
-- installed by a previous call to Install_Handler.
|
-- installed by a previous call to Install_Handler.
|
||||||
pragma Export (C, Handler_Installed, "__gnat_handler_installed");
|
|
||||||
|
|
||||||
------------------------
|
------------------------
|
||||||
-- Local procedures --
|
-- Local procedures --
|
||||||
|
@ -154,8 +153,10 @@ package body System.Init is
|
||||||
------------------------
|
------------------------
|
||||||
|
|
||||||
procedure GNAT_Error_Handler (Sig : Signal) is
|
procedure GNAT_Error_Handler (Sig : Signal) is
|
||||||
Mask : aliased sigset_t;
|
Mask : aliased sigset_t;
|
||||||
|
|
||||||
Result : int;
|
Result : int;
|
||||||
|
pragma Unreferenced (Result);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
-- VxWorks will always mask out the signal during the signal
|
-- VxWorks will always mask out the signal during the signal
|
||||||
|
@ -210,23 +211,24 @@ package body System.Init is
|
||||||
Num_Interrupt_States : Integer;
|
Num_Interrupt_States : Integer;
|
||||||
Unreserve_All_Interrupts : Integer;
|
Unreserve_All_Interrupts : Integer;
|
||||||
Exception_Tracebacks : Integer;
|
Exception_Tracebacks : Integer;
|
||||||
Zero_Cost_Exceptions : Integer) is
|
Zero_Cost_Exceptions : Integer)
|
||||||
|
is
|
||||||
begin
|
begin
|
||||||
-- If this procedure has been already called once, check that the
|
-- If this procedure has been already called once, check that the
|
||||||
-- arguments in this call are consistent with the ones in the
|
-- arguments in this call are consistent with the ones in the
|
||||||
-- previous calls. Otherwise, raise a Program_Error exception.
|
-- previous calls. Otherwise, raise a Program_Error exception.
|
||||||
--
|
|
||||||
-- We do not check for consistency of the wide character encoding
|
-- We do not check for consistency of the wide character encoding
|
||||||
-- method. This default affects only Wide_Text_IO where no
|
-- method. This default affects only Wide_Text_IO where no
|
||||||
-- explicit coding method is given, and there is no particular
|
-- explicit coding method is given, and there is no particular
|
||||||
-- reason to let this default be affected by the source
|
-- reason to let this default be affected by the source
|
||||||
-- representation of a library in any case.
|
-- representation of a library in any case.
|
||||||
--
|
|
||||||
-- We do not check either for the consistency of exception tracebacks,
|
-- We do not check either for the consistency of exception tracebacks,
|
||||||
-- because exception tracebacks are not normally set in Stand-Alone
|
-- because exception tracebacks are not normally set in Stand-Alone
|
||||||
-- libraries. If a library or the main program set the exception
|
-- libraries. If a library or the main program set the exception
|
||||||
-- tracebacks, then they are never reset afterwards (see below).
|
-- tracebacks, then they are never reset afterwards (see below).
|
||||||
--
|
|
||||||
-- The value of main_priority is meaningful only when we are
|
-- The value of main_priority is meaningful only when we are
|
||||||
-- invoked from the main program elaboration routine of an Ada
|
-- invoked from the main program elaboration routine of an Ada
|
||||||
-- application. Checking the consistency of this parameter should
|
-- 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
|
-- that the case where the main program is not written in Ada is
|
||||||
-- also properly handled, since the default value will then be
|
-- also properly handled, since the default value will then be
|
||||||
-- used for this parameter.
|
-- used for this parameter.
|
||||||
--
|
|
||||||
-- For identical reasons, the consistency of time_slice_val should
|
-- For identical reasons, the consistency of time_slice_val should
|
||||||
-- not be checked.
|
-- not be checked.
|
||||||
|
|
||||||
if Already_Called then
|
if Already_Called then
|
||||||
if (Gl_Locking_Policy /= Locking_Policy) or
|
if (Gl_Locking_Policy /= Locking_Policy) or else
|
||||||
(Gl_Queuing_Policy /= Queuing_Policy) or
|
(Gl_Queuing_Policy /= Queuing_Policy) or else
|
||||||
(Gl_Task_Dispatching_Policy /= Task_Dispatching_Policy) or
|
(Gl_Task_Dispatching_Policy /= Task_Dispatching_Policy) or else
|
||||||
(Gl_Unreserve_All_Interrupts /= Unreserve_All_Interrupts) or
|
(Gl_Unreserve_All_Interrupts /= Unreserve_All_Interrupts) or else
|
||||||
(Gl_Exception_Tracebacks /= Exception_Tracebacks) or
|
(Gl_Exception_Tracebacks /= Exception_Tracebacks) or else
|
||||||
(Gl_Zero_Cost_Exceptions /= Zero_Cost_Exceptions)
|
(Gl_Zero_Cost_Exceptions /= Zero_Cost_Exceptions)
|
||||||
then
|
then
|
||||||
raise Program_Error;
|
raise Program_Error;
|
||||||
|
@ -285,7 +287,9 @@ package body System.Init is
|
||||||
procedure Install_Handler is
|
procedure Install_Handler is
|
||||||
Mask : aliased sigset_t;
|
Mask : aliased sigset_t;
|
||||||
Signal_Action : aliased struct_sigaction;
|
Signal_Action : aliased struct_sigaction;
|
||||||
Result : Interfaces.C.int;
|
|
||||||
|
Result : Interfaces.C.int;
|
||||||
|
pragma Unreferenced (Result);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
-- Set up signal handler to map synchronous signals to appropriate
|
-- Set up signal handler to map synchronous signals to appropriate
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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.
|
-- Restore default handlers for interrupt servers.
|
||||||
|
|
||||||
-- This is called by the Interrupt_Manager task when it receives the abort
|
-- This is called by the Interrupt_Manager task when it receives the abort
|
||||||
-- signal during program finalization.
|
-- signal during program finalization.
|
||||||
|
|
||||||
procedure Finalize_Interrupt_Servers is
|
procedure Finalize_Interrupt_Servers is
|
||||||
|
HW_Interrupts : constant Boolean := HW_Interrupt'Last >= 0;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if HW_Interrupt'Last >= 0 then
|
if HW_Interrupts then
|
||||||
for Int in HW_Interrupt loop
|
for Int in HW_Interrupt loop
|
||||||
if Server_ID (Interrupt_ID (Int)) /= null
|
if Server_ID (Interrupt_ID (Int)) /= null
|
||||||
and then
|
and then
|
||||||
|
@ -527,11 +530,16 @@ package body System.Interrupts is
|
||||||
is
|
is
|
||||||
use Interfaces.VxWorks;
|
use Interfaces.VxWorks;
|
||||||
|
|
||||||
Vec : constant Interrupt_Vector :=
|
Vec : constant Interrupt_Vector :=
|
||||||
INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt));
|
INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt));
|
||||||
|
|
||||||
Old_Handler : constant VOIDFUNCPTR :=
|
Old_Handler : constant VOIDFUNCPTR :=
|
||||||
intVecGet (INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt)));
|
intVecGet
|
||||||
|
(INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt)));
|
||||||
|
|
||||||
Stat : Interfaces.VxWorks.STATUS;
|
Stat : Interfaces.VxWorks.STATUS;
|
||||||
|
pragma Unreferenced (Stat);
|
||||||
|
-- ??? shouldn't we test Stat at least in a pragma Assert?
|
||||||
|
|
||||||
begin
|
begin
|
||||||
-- Only install umbrella handler when no Ada handler has already been
|
-- 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
|
if Default_Handler (Interrupt) = null then
|
||||||
Stat :=
|
Stat :=
|
||||||
intConnect (Vec, VOIDFUNCPTR (Handler), System.Address (Interrupt));
|
intConnect (Vec, Handler, System.Address (Interrupt));
|
||||||
Default_Handler (Interrupt) := Old_Handler;
|
Default_Handler (Interrupt) := Old_Handler;
|
||||||
end if;
|
end if;
|
||||||
end Install_Umbrella_Handler;
|
end Install_Umbrella_Handler;
|
||||||
|
@ -611,7 +619,7 @@ package body System.Interrupts is
|
||||||
|
|
||||||
Ptr := Registered_Handler_Head;
|
Ptr := Registered_Handler_Head;
|
||||||
|
|
||||||
while (Ptr /= null) loop
|
while Ptr /= null loop
|
||||||
if Ptr.H = Fat.Handler_Addr then
|
if Ptr.H = Fat.Handler_Addr then
|
||||||
return True;
|
return True;
|
||||||
end if;
|
end if;
|
||||||
|
@ -653,8 +661,10 @@ package body System.Interrupts is
|
||||||
-- server task deletes its semaphore and terminates.
|
-- server task deletes its semaphore and terminates.
|
||||||
|
|
||||||
procedure Notify_Interrupt (Param : System.Address) is
|
procedure Notify_Interrupt (Param : System.Address) is
|
||||||
Interrupt : Interrupt_ID := Interrupt_ID (Param);
|
Interrupt : constant Interrupt_ID := Interrupt_ID (Param);
|
||||||
|
|
||||||
Discard_Result : STATUS;
|
Discard_Result : STATUS;
|
||||||
|
pragma Unreferenced (Discard_Result);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Discard_Result := semGive (Semaphore_ID_Map (Interrupt));
|
Discard_Result := semGive (Semaphore_ID_Map (Interrupt));
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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
|
procedure Notify_Exception (signo : Signal) is
|
||||||
Mask : aliased sigset_t;
|
Mask : aliased sigset_t;
|
||||||
Result : int;
|
|
||||||
My_Id : t_id;
|
My_Id : t_id;
|
||||||
|
|
||||||
|
Result : int;
|
||||||
|
pragma Unreferenced (Result);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access);
|
Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access);
|
||||||
Result := sigdelset (Mask'Access, signo);
|
Result := sigdelset (Mask'Access, signo);
|
||||||
|
|
|
@ -67,7 +67,7 @@ package body MLib.Tgt is
|
||||||
-- Archive_Ext --
|
-- Archive_Ext --
|
||||||
-----------------
|
-----------------
|
||||||
|
|
||||||
function Archive_Ext return String is
|
function Archive_Ext return String is
|
||||||
begin
|
begin
|
||||||
return "a";
|
return "a";
|
||||||
end Archive_Ext;
|
end Archive_Ext;
|
||||||
|
@ -150,11 +150,13 @@ package body MLib.Tgt is
|
||||||
-----------------------------
|
-----------------------------
|
||||||
|
|
||||||
function Get_Target_Suffix return String 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;
|
Index : Positive := Target_Name'First;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
while ((Index < Target_Name'Last) and then
|
while Index < Target_Name'Last
|
||||||
(Target_Name (Index + 1) /= '-')) loop
|
and then Target_Name (Index + 1) /= '-'
|
||||||
|
loop
|
||||||
Index := Index + 1;
|
Index := Index + 1;
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
|
|
|
@ -717,9 +717,8 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
procedure Yield (Do_Yield : Boolean := True) is
|
procedure Yield (Do_Yield : Boolean := True) is
|
||||||
pragma Unreferenced (Do_Yield);
|
pragma Unreferenced (Do_Yield);
|
||||||
|
|
||||||
Result : int;
|
Result : int;
|
||||||
|
pragma Unreferenced (Result);
|
||||||
begin
|
begin
|
||||||
Result := taskDelay (0);
|
Result := taskDelay (0);
|
||||||
end Yield;
|
end Yield;
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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 Ada.Tags; use Ada.Tags;
|
||||||
with System; use System;
|
with System; use System;
|
||||||
|
@ -102,14 +102,14 @@ package body Interfaces.CPP is
|
||||||
function Displaced_This
|
function Displaced_This
|
||||||
(Current_This : System.Address;
|
(Current_This : System.Address;
|
||||||
Vptr : Vtable_Ptr;
|
Vptr : Vtable_Ptr;
|
||||||
Position : Positive)
|
Position : Positive) return System.Address
|
||||||
return System.Address
|
|
||||||
is
|
is
|
||||||
pragma Warnings (Off, Vptr);
|
pragma Warnings (Off, Vptr);
|
||||||
pragma Warnings (Off, Position);
|
pragma Warnings (Off, Position);
|
||||||
begin
|
begin
|
||||||
return Current_This;
|
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;
|
end Displaced_This;
|
||||||
|
|
||||||
-----------------------
|
-----------------------
|
||||||
|
@ -118,8 +118,7 @@ package body Interfaces.CPP is
|
||||||
|
|
||||||
function CPP_CW_Membership
|
function CPP_CW_Membership
|
||||||
(Obj_Tag : Vtable_Ptr;
|
(Obj_Tag : Vtable_Ptr;
|
||||||
Typ_Tag : Vtable_Ptr)
|
Typ_Tag : Vtable_Ptr) return Boolean
|
||||||
return Boolean
|
|
||||||
is
|
is
|
||||||
Pos : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth;
|
Pos : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth;
|
||||||
begin
|
begin
|
||||||
|
@ -153,14 +152,24 @@ package body Interfaces.CPP is
|
||||||
return T.TSD.Idepth;
|
return T.TSD.Idepth;
|
||||||
end CPP_Get_Inheritance_Depth;
|
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 --
|
-- CPP_Get_Prim_Op_Address --
|
||||||
-------------------------
|
-----------------------------
|
||||||
|
|
||||||
function CPP_Get_Prim_Op_Address
|
function CPP_Get_Prim_Op_Address
|
||||||
(T : Vtable_Ptr;
|
(T : Vtable_Ptr;
|
||||||
Position : Positive)
|
Position : Positive) return Address
|
||||||
return Address is
|
is
|
||||||
begin
|
begin
|
||||||
return T.Prims_Ptr (Position).Pfn;
|
return T.Prims_Ptr (Position).Pfn;
|
||||||
end CPP_Get_Prim_Op_Address;
|
end CPP_Get_Prim_Op_Address;
|
||||||
|
@ -189,14 +198,14 @@ package body Interfaces.CPP is
|
||||||
--------------------
|
--------------------
|
||||||
|
|
||||||
procedure CPP_Inherit_DT
|
procedure CPP_Inherit_DT
|
||||||
(Old_T : Vtable_Ptr;
|
(Old_T : Vtable_Ptr;
|
||||||
New_T : Vtable_Ptr;
|
New_T : Vtable_Ptr;
|
||||||
Entry_Count : Natural)
|
Entry_Count : Natural)
|
||||||
is
|
is
|
||||||
begin
|
begin
|
||||||
if Old_T /= null then
|
if Old_T /= null then
|
||||||
New_T.Prims_Ptr (1 .. Entry_Count)
|
New_T.Prims_Ptr (1 .. Entry_Count) :=
|
||||||
:= Old_T.Prims_Ptr (1 .. Entry_Count);
|
Old_T.Prims_Ptr (1 .. Entry_Count);
|
||||||
end if;
|
end if;
|
||||||
end CPP_Inherit_DT;
|
end CPP_Inherit_DT;
|
||||||
|
|
||||||
|
@ -208,8 +217,8 @@ package body Interfaces.CPP is
|
||||||
(Old_TSD : Address;
|
(Old_TSD : Address;
|
||||||
New_Tag : Vtable_Ptr)
|
New_Tag : Vtable_Ptr)
|
||||||
is
|
is
|
||||||
TSD : constant Type_Specific_Data_Ptr
|
TSD : constant Type_Specific_Data_Ptr :=
|
||||||
:= To_Type_Specific_Data_Ptr (Old_TSD);
|
To_Type_Specific_Data_Ptr (Old_TSD);
|
||||||
|
|
||||||
New_TSD : Type_Specific_Data renames New_Tag.TSD.all;
|
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;
|
T.Prims_Ptr (Position).Pfn := Value;
|
||||||
end CPP_Set_Prim_Op_Address;
|
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 --
|
-- CPP_Set_Remotely_Callable --
|
||||||
-------------------------------
|
-------------------------------
|
||||||
|
@ -293,8 +313,7 @@ package body Interfaces.CPP is
|
||||||
-------------------
|
-------------------
|
||||||
|
|
||||||
function Expanded_Name (T : Vtable_Ptr) return String 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
|
begin
|
||||||
return Result (1 .. Length (Result));
|
return Result (1 .. Length (Result));
|
||||||
end Expanded_Name;
|
end Expanded_Name;
|
||||||
|
@ -304,8 +323,7 @@ package body Interfaces.CPP is
|
||||||
------------------
|
------------------
|
||||||
|
|
||||||
function External_Tag (T : Vtable_Ptr) return String 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
|
begin
|
||||||
return Result (1 .. Length (Result));
|
return Result (1 .. Length (Result));
|
||||||
end External_Tag;
|
end External_Tag;
|
||||||
|
@ -325,16 +343,4 @@ package body Interfaces.CPP is
|
||||||
return Len - 1;
|
return Len - 1;
|
||||||
end Length;
|
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;
|
end Interfaces.CPP;
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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;
|
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 --
|
-- fread --
|
||||||
------------
|
------------
|
||||||
|
@ -46,31 +54,36 @@ package body Interfaces.C_Streams is
|
||||||
(buffer : voids;
|
(buffer : voids;
|
||||||
size : size_t;
|
size : size_t;
|
||||||
count : size_t;
|
count : size_t;
|
||||||
stream : FILEs)
|
stream : FILEs) return size_t
|
||||||
return size_t
|
|
||||||
is
|
is
|
||||||
Get_Count : size_t := 0;
|
Get_Count : size_t := 0;
|
||||||
|
|
||||||
type Buffer_Type is array (size_t range 1 .. count,
|
type Buffer_Type is array (size_t range 1 .. count,
|
||||||
size_t range 1 .. size) of Character;
|
size_t range 1 .. size) of Character;
|
||||||
type Buffer_Access is access Buffer_Type;
|
type Buffer_Access is access Buffer_Type;
|
||||||
function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
|
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.
|
-- This Fread goes with the Fwrite below.
|
||||||
-- The C library fread sometimes can't read fputc generated files.
|
-- The C library fread sometimes can't read fputc generated files.
|
||||||
|
|
||||||
for C in 1 .. count loop
|
for C in 1 .. count loop
|
||||||
for S in 1 .. size loop
|
for S in 1 .. size loop
|
||||||
Ch := fgetc (stream);
|
Ch := fgetc (stream);
|
||||||
|
|
||||||
if Ch = EOF then
|
if Ch = EOF then
|
||||||
return Get_Count;
|
return Get_Count;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
BA.all (C, S) := Character'Val (Ch);
|
BA.all (C, S) := Character'Val (Ch);
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
Get_Count := Get_Count + 1;
|
Get_Count := Get_Count + 1;
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
return Get_Count;
|
return Get_Count;
|
||||||
end fread;
|
end fread;
|
||||||
|
|
||||||
|
@ -83,31 +96,36 @@ package body Interfaces.C_Streams is
|
||||||
index : size_t;
|
index : size_t;
|
||||||
size : size_t;
|
size : size_t;
|
||||||
count : size_t;
|
count : size_t;
|
||||||
stream : FILEs)
|
stream : FILEs) return size_t
|
||||||
return size_t
|
|
||||||
is
|
is
|
||||||
Get_Count : size_t := 0;
|
Get_Count : size_t := 0;
|
||||||
|
|
||||||
type Buffer_Type is array (size_t range 1 .. count,
|
type Buffer_Type is array (size_t range 1 .. count,
|
||||||
size_t range 1 .. size) of Character;
|
size_t range 1 .. size) of Character;
|
||||||
type Buffer_Access is access Buffer_Type;
|
type Buffer_Access is access Buffer_Type;
|
||||||
function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
|
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.
|
-- This Fread goes with the Fwrite below.
|
||||||
-- The C library fread sometimes can't read fputc generated files.
|
-- The C library fread sometimes can't read fputc generated files.
|
||||||
|
|
||||||
for C in 1 + index .. count + index loop
|
for C in 1 + index .. count + index loop
|
||||||
for S in 1 .. size loop
|
for S in 1 .. size loop
|
||||||
Ch := fgetc (stream);
|
Ch := fgetc (stream);
|
||||||
|
|
||||||
if Ch = EOF then
|
if Ch = EOF then
|
||||||
return Get_Count;
|
return Get_Count;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
BA.all (C, S) := Character'Val (Ch);
|
BA.all (C, S) := Character'Val (Ch);
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
Get_Count := Get_Count + 1;
|
Get_Count := Get_Count + 1;
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
return Get_Count;
|
return Get_Count;
|
||||||
end fread;
|
end fread;
|
||||||
|
|
||||||
|
@ -119,17 +137,18 @@ package body Interfaces.C_Streams is
|
||||||
(buffer : voids;
|
(buffer : voids;
|
||||||
size : size_t;
|
size : size_t;
|
||||||
count : size_t;
|
count : size_t;
|
||||||
stream : FILEs)
|
stream : FILEs) return size_t
|
||||||
return size_t
|
|
||||||
is
|
is
|
||||||
Put_Count : size_t := 0;
|
Put_Count : size_t := 0;
|
||||||
|
|
||||||
type Buffer_Type is array (size_t range 1 .. count,
|
type Buffer_Type is array (size_t range 1 .. count,
|
||||||
size_t range 1 .. size) of Character;
|
size_t range 1 .. size) of Character;
|
||||||
type Buffer_Access is access Buffer_Type;
|
type Buffer_Access is access Buffer_Type;
|
||||||
function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
|
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
|
-- Fwrite on VMS has the undesirable effect of always generating at
|
||||||
-- least one record of output per call, regardless of buffering. To
|
-- least one record of output per call, regardless of buffering. To
|
||||||
-- get around this, we do multiple fputc calls instead.
|
-- get around this, we do multiple fputc calls instead.
|
||||||
|
@ -140,8 +159,10 @@ package body Interfaces.C_Streams is
|
||||||
return Put_Count;
|
return Put_Count;
|
||||||
end if;
|
end if;
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
Put_Count := Put_Count + 1;
|
Put_Count := Put_Count + 1;
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
return Put_Count;
|
return Put_Count;
|
||||||
end fwrite;
|
end fwrite;
|
||||||
|
|
||||||
|
@ -153,12 +174,11 @@ package body Interfaces.C_Streams is
|
||||||
(stream : FILEs;
|
(stream : FILEs;
|
||||||
buffer : chars;
|
buffer : chars;
|
||||||
mode : int;
|
mode : int;
|
||||||
size : size_t)
|
size : size_t) return int
|
||||||
return int
|
|
||||||
is
|
is
|
||||||
use type System.Address;
|
use type System.Address;
|
||||||
begin
|
|
||||||
|
|
||||||
|
begin
|
||||||
-- In order for the above fwrite hack to work, we must always buffer
|
-- In order for the above fwrite hack to work, we must always buffer
|
||||||
-- stdout and stderr. Is_regular_file on VMS cannot detect when
|
-- stdout and stderr. Is_regular_file on VMS cannot detect when
|
||||||
-- these are redirected to a file, so checking for that condition
|
-- these are redirected to a file, so checking for that condition
|
||||||
|
|
|
@ -725,7 +725,7 @@ package body System.Task_Primitives.Operations is
|
||||||
|
|
||||||
procedure Yield (Do_Yield : Boolean := True) is
|
procedure Yield (Do_Yield : Boolean := True) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
pragma Unreferenced (Result);
|
||||||
begin
|
begin
|
||||||
if Do_Yield then
|
if Do_Yield then
|
||||||
Result := sched_yield;
|
Result := sched_yield;
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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
|
procedure Initialize (Environment_Task : Task_ID) is
|
||||||
pragma Warnings (Off, Environment_Task);
|
pragma Warnings (Off, Environment_Task);
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result := pthread_key_create (ATCB_Key'Access, null);
|
Result := pthread_key_create (ATCB_Key'Access, null);
|
||||||
pragma Assert (Result = 0);
|
pragma Assert (Result = 0);
|
||||||
|
@ -64,7 +63,6 @@ package body Specific is
|
||||||
|
|
||||||
procedure Set (Self_Id : Task_ID) is
|
procedure Set (Self_Id : Task_ID) is
|
||||||
Result : Interfaces.C.int;
|
Result : Interfaces.C.int;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id));
|
Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id));
|
||||||
pragma Assert (Result = 0);
|
pragma Assert (Result = 0);
|
||||||
|
|
|
@ -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>
|
2003-12-23 Kelley Cook <kcook@gcc.gnu.org>
|
||||||
|
|
||||||
* gnat_ug.texi: Force a CVS commit by updating copyright.
|
* gnat_ug.texi: Force a CVS commit by updating copyright.
|
||||||
|
|
|
@ -1207,6 +1207,7 @@ endif
|
||||||
# This command transforms (YYYYMMDD) into YY,MMDD
|
# 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/')
|
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
|
TOOLS_LIBS_LO := --for-linker=sys\\$$\$$library:trace.exe
|
||||||
|
LIBRARY_VERSION := $(subst .,_,$(LIB_VERSION))
|
||||||
endif
|
endif
|
||||||
|
|
||||||
ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),)
|
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_GNATMAKE_OBJS = mdll.o mdll-utl.o mdll-fil.o
|
||||||
EXTRA_GNATRTL_NONTASKING_OBJS = g-regist.o
|
EXTRA_GNATRTL_NONTASKING_OBJS = g-regist.o
|
||||||
soext = .dll
|
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
|
GNATLIB_SHARED = gnatlib-shared-win32
|
||||||
LIBRARY_VERSION := $(LIB_VERSION)
|
LIBRARY_VERSION := $(LIB_VERSION)
|
||||||
endif
|
endif
|
||||||
|
@ -1688,7 +1691,7 @@ install-gnatlib: ../stamp-gnatlib
|
||||||
-$(INSTALL_DATA) rts/Makefile.prolog $(DESTDIR)$(ADA_SHARE_MAKE_DIR)
|
-$(INSTALL_DATA) rts/Makefile.prolog $(DESTDIR)$(ADA_SHARE_MAKE_DIR)
|
||||||
-$(INSTALL_DATA) rts/Makefile.generic $(DESTDIR)$(ADA_SHARE_MAKE_DIR)
|
-$(INSTALL_DATA) rts/Makefile.generic $(DESTDIR)$(ADA_SHARE_MAKE_DIR)
|
||||||
for file in rts/*.ali; do \
|
for file in rts/*.ali; do \
|
||||||
$(INSTALL_DATA) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
|
$(INSTALL_DATA_DATE) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
|
||||||
done
|
done
|
||||||
-$(INSTALL_DATA) rts/g-trasym$(objext) $(DESTDIR)$(ADA_RTL_OBJ_DIR)
|
-$(INSTALL_DATA) rts/g-trasym$(objext) $(DESTDIR)$(ADA_RTL_OBJ_DIR)
|
||||||
-for file in rts/*$(arext);do \
|
-for file in rts/*$(arext);do \
|
||||||
|
@ -1707,11 +1710,6 @@ else
|
||||||
$(INSTALL) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
|
$(INSTALL) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
|
||||||
done
|
done
|
||||||
endif
|
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.
|
# This copy must be done preserving the date on the original file.
|
||||||
for file in rts/*.adb rts/*.ads; do \
|
for file in rts/*.adb rts/*.ads; do \
|
||||||
$(INSTALL_DATA_DATE) $$file $(DESTDIR)$(ADA_INCLUDE_DIR); \
|
$(INSTALL_DATA_DATE) $$file $(DESTDIR)$(ADA_INCLUDE_DIR); \
|
||||||
|
@ -1898,8 +1896,6 @@ gnatlib-shared-default:
|
||||||
-o libgnarl-$(LIBRARY_VERSION)$(soext) \
|
-o libgnarl-$(LIBRARY_VERSION)$(soext) \
|
||||||
$(GNATRTL_TASKING_OBJS) \
|
$(GNATRTL_TASKING_OBJS) \
|
||||||
$(SO_OPTS)libgnarl-$(LIBRARY_VERSION)$(soext) $(THREADSLIB)
|
$(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:
|
gnatlib-shared-dual:
|
||||||
$(MAKE) $(FLAGS_TO_PASS) \
|
$(MAKE) $(FLAGS_TO_PASS) \
|
||||||
|
@ -1916,10 +1912,25 @@ gnatlib-shared-dual:
|
||||||
gnatlib
|
gnatlib
|
||||||
$(MV) libgna*$(soext) rts
|
$(MV) libgna*$(soext) rts
|
||||||
|
|
||||||
# Note that on Win32 the auto-import does not work for DLL, so on the
|
gnatlib-shared-dual-win32:
|
||||||
# platform we have a specific setup. The libgnat.dll contains only
|
$(MAKE) $(FLAGS_TO_PASS) \
|
||||||
# non-tasking objects and libgnarl.dll contains tasking and non-tasking
|
GNATLIBFLAGS="$(GNATLIBFLAGS)" \
|
||||||
# objects. A tasking program must be linked with libgnarl.dll only.
|
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:
|
gnatlib-shared-win32:
|
||||||
$(MAKE) $(FLAGS_TO_PASS) \
|
$(MAKE) $(FLAGS_TO_PASS) \
|
||||||
GNATLIBFLAGS="$(GNATLIBFLAGS)" \
|
GNATLIBFLAGS="$(GNATLIBFLAGS)" \
|
||||||
|
@ -1936,8 +1947,6 @@ gnatlib-shared-win32:
|
||||||
$(GNATRTL_TASKING_OBJS) \
|
$(GNATRTL_TASKING_OBJS) \
|
||||||
$(SO_OPTS)libgnarl-$(LIBRARY_VERSION)$(soext) \
|
$(SO_OPTS)libgnarl-$(LIBRARY_VERSION)$(soext) \
|
||||||
$(THREADSLIB) -Wl,libgnat-$(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:
|
gnatlib-shared-vms:
|
||||||
$(MAKE) $(FLAGS_TO_PASS) \
|
$(MAKE) $(FLAGS_TO_PASS) \
|
||||||
|
@ -1951,7 +1960,7 @@ gnatlib-shared-vms:
|
||||||
$(SHLIB_SYMVEC) >> SYMVEC_$$$$.opt && \
|
$(SHLIB_SYMVEC) >> SYMVEC_$$$$.opt && \
|
||||||
echo "case_sensitive=NO" >> SYMVEC_$$$$.opt && \
|
echo "case_sensitive=NO" >> SYMVEC_$$$$.opt && \
|
||||||
../../xgcc -g -B../../ -nostartfiles -shared -shared-libgcc \
|
../../xgcc -g -B../../ -nostartfiles -shared -shared-libgcc \
|
||||||
-o libgnat_s$(soext) libgnat.a \
|
-o libgnat_$(LIBRARY_VERSION)$(soext) libgnat.a \
|
||||||
sys\$$library:trace.exe \
|
sys\$$library:trace.exe \
|
||||||
--for-linker=/noinform \
|
--for-linker=/noinform \
|
||||||
--for-linker=SYMVEC_$$$$.opt \
|
--for-linker=SYMVEC_$$$$.opt \
|
||||||
|
@ -1961,8 +1970,8 @@ gnatlib-shared-vms:
|
||||||
$(SHLIB_SYMVEC) >> SYMVEC_$$$$.opt && \
|
$(SHLIB_SYMVEC) >> SYMVEC_$$$$.opt && \
|
||||||
echo "case_sensitive=NO" >> SYMVEC_$$$$.opt && \
|
echo "case_sensitive=NO" >> SYMVEC_$$$$.opt && \
|
||||||
../../xgcc -g -B../../ -nostartfiles -shared -shared-libgcc \
|
../../xgcc -g -B../../ -nostartfiles -shared -shared-libgcc \
|
||||||
-o libgnarl_s$(soext) \
|
-o libgnarl_$(LIBRARY_VERSION)$(soext) \
|
||||||
libgnarl.a libgnat_s$(soext) \
|
libgnarl.a libgnat_$(LIBRARY_VERSION)$(soext) \
|
||||||
sys\$$library:trace.exe \
|
sys\$$library:trace.exe \
|
||||||
--for-linker=/noinform \
|
--for-linker=/noinform \
|
||||||
--for-linker=SYMVEC_$$$$.opt \
|
--for-linker=SYMVEC_$$$$.opt \
|
||||||
|
|
|
@ -18,7 +18,7 @@
|
||||||
#the Free Software Foundation, 59 Temple Place - Suite 330,
|
#the Free Software Foundation, 59 Temple Place - Suite 330,
|
||||||
#Boston, MA 02111-1307, USA.
|
#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).
|
# and NT and VMS versions).
|
||||||
|
|
||||||
# It's purpose is to allow the separate maintainence of the list of
|
# It's purpose is to allow the separate maintainence of the list of
|
||||||
|
@ -236,6 +236,7 @@ GNATRTL_NONTASKING_OBJS= \
|
||||||
g-pehage$(objext) \
|
g-pehage$(objext) \
|
||||||
g-regexp$(objext) \
|
g-regexp$(objext) \
|
||||||
g-regpat$(objext) \
|
g-regpat$(objext) \
|
||||||
|
g-sestin$(objext) \
|
||||||
g-soccon$(objext) \
|
g-soccon$(objext) \
|
||||||
g-socket$(objext) \
|
g-socket$(objext) \
|
||||||
g-socthi$(objext) \
|
g-socthi$(objext) \
|
||||||
|
|
|
@ -7,7 +7,7 @@
|
||||||
-- S p e c --
|
-- S p e c --
|
||||||
-- (C Library Version, non-x86) --
|
-- (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 --
|
-- 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- --
|
-- 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
|
-- One advantage of using this package is that it will interface directly to
|
||||||
-- hardware instructions, such as the those provided on the Intel x86.
|
-- hardware instructions, such as the those provided on the Intel x86.
|
||||||
|
|
||||||
-- Note: there are two versions of this package. One using the normal IEEE
|
-- This version is for use with normal Unix math functions. Alternative
|
||||||
-- 64-bit double format (which is this version), and one using 80-bit x86
|
-- packages are used on OpenVMS (different import names), VxWorks (no
|
||||||
-- long double (see file 4onumaux.ads).
|
-- 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
|
package Ada.Numerics.Aux is
|
||||||
pragma Pure (Aux);
|
pragma Pure (Aux);
|
||||||
|
@ -49,48 +51,61 @@ pragma Pure (Aux);
|
||||||
pragma Linker_Options ("-lm");
|
pragma Linker_Options ("-lm");
|
||||||
|
|
||||||
type Double is digits 15;
|
type Double is digits 15;
|
||||||
pragma Float_Representation (IEEE_Float, Double);
|
-- Type Double is the type used to call the C routines
|
||||||
-- 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
|
-- We import these functions directly from C. Note that we label them
|
||||||
-- since we use the IEEE version of the C library with VMS.
|
-- all as pure functions, because indeed all of them are in fact pure!
|
||||||
|
|
||||||
function Sin (X : Double) return Double;
|
function Sin (X : Double) return Double;
|
||||||
pragma Import (C, Sin, "sin");
|
pragma Import (C, Sin, "sin");
|
||||||
|
pragma Pure_Function (Sin);
|
||||||
|
|
||||||
function Cos (X : Double) return Double;
|
function Cos (X : Double) return Double;
|
||||||
pragma Import (C, Cos, "cos");
|
pragma Import (C, Cos, "cos");
|
||||||
|
pragma Pure_Function (Cos);
|
||||||
|
|
||||||
function Tan (X : Double) return Double;
|
function Tan (X : Double) return Double;
|
||||||
pragma Import (C, Tan, "tan");
|
pragma Import (C, Tan, "tan");
|
||||||
|
pragma Pure_Function (Tan);
|
||||||
|
|
||||||
function Exp (X : Double) return Double;
|
function Exp (X : Double) return Double;
|
||||||
pragma Import (C, Exp, "exp");
|
pragma Import (C, Exp, "exp");
|
||||||
|
pragma Pure_Function (Exp);
|
||||||
|
|
||||||
function Sqrt (X : Double) return Double;
|
function Sqrt (X : Double) return Double;
|
||||||
pragma Import (C, Sqrt, "sqrt");
|
pragma Import (C, Sqrt, "sqrt");
|
||||||
|
pragma Pure_Function (Sqrt);
|
||||||
|
|
||||||
function Log (X : Double) return Double;
|
function Log (X : Double) return Double;
|
||||||
pragma Import (C, Log, "log");
|
pragma Import (C, Log, "log");
|
||||||
|
pragma Pure_Function (Log);
|
||||||
|
|
||||||
function Acos (X : Double) return Double;
|
function Acos (X : Double) return Double;
|
||||||
pragma Import (C, Acos, "acos");
|
pragma Import (C, Acos, "acos");
|
||||||
|
pragma Pure_Function (Acos);
|
||||||
|
|
||||||
function Asin (X : Double) return Double;
|
function Asin (X : Double) return Double;
|
||||||
pragma Import (C, Asin, "asin");
|
pragma Import (C, Asin, "asin");
|
||||||
|
pragma Pure_Function (Asin);
|
||||||
|
|
||||||
function Atan (X : Double) return Double;
|
function Atan (X : Double) return Double;
|
||||||
pragma Import (C, Atan, "atan");
|
pragma Import (C, Atan, "atan");
|
||||||
|
pragma Pure_Function (Atan);
|
||||||
|
|
||||||
function Sinh (X : Double) return Double;
|
function Sinh (X : Double) return Double;
|
||||||
pragma Import (C, Sinh, "sinh");
|
pragma Import (C, Sinh, "sinh");
|
||||||
|
pragma Pure_Function (Sinh);
|
||||||
|
|
||||||
function Cosh (X : Double) return Double;
|
function Cosh (X : Double) return Double;
|
||||||
pragma Import (C, Cosh, "cosh");
|
pragma Import (C, Cosh, "cosh");
|
||||||
|
pragma Pure_Function (Cosh);
|
||||||
|
|
||||||
function Tanh (X : Double) return Double;
|
function Tanh (X : Double) return Double;
|
||||||
pragma Import (C, Tanh, "tanh");
|
pragma Import (C, Tanh, "tanh");
|
||||||
|
pragma Pure_Function (Tanh);
|
||||||
|
|
||||||
function Pow (X, Y : Double) return Double;
|
function Pow (X, Y : Double) return Double;
|
||||||
pragma Import (C, Pow, "pow");
|
pragma Import (C, Pow, "pow");
|
||||||
|
pragma Pure_Function (Pow);
|
||||||
|
|
||||||
end Ada.Numerics.Aux;
|
end Ada.Numerics.Aux;
|
||||||
|
|
|
@ -92,7 +92,6 @@ package body ALI is
|
||||||
Task_Dispatching_Policy_Specified := ' ';
|
Task_Dispatching_Policy_Specified := ' ';
|
||||||
Unreserve_All_Interrupts_Specified := False;
|
Unreserve_All_Interrupts_Specified := False;
|
||||||
Zero_Cost_Exceptions_Specified := False;
|
Zero_Cost_Exceptions_Specified := False;
|
||||||
|
|
||||||
end Initialize_ALI;
|
end Initialize_ALI;
|
||||||
|
|
||||||
--------------
|
--------------
|
||||||
|
@ -143,8 +142,9 @@ package body ALI is
|
||||||
function Getc return Character;
|
function Getc return Character;
|
||||||
-- Get next character, bumping P past the character obtained
|
-- Get next character, bumping P past the character obtained
|
||||||
|
|
||||||
function Get_Name (Lower : Boolean := False;
|
function Get_Name
|
||||||
Ignore_Spaces : Boolean := False) return Name_Id;
|
(Lower : Boolean := False;
|
||||||
|
Ignore_Spaces : Boolean := False) return Name_Id;
|
||||||
-- Skip blanks, then scan out a name (name is left in Name_Buffer with
|
-- 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).
|
-- 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
|
-- 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;
|
procedure Skip_Space;
|
||||||
-- Skip past white space (blanks or horizontal tab)
|
-- 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 --
|
-- At_End_Of_Field --
|
||||||
---------------------
|
---------------------
|
||||||
|
@ -480,6 +484,17 @@ package body ALI is
|
||||||
end loop;
|
end loop;
|
||||||
end Skip_Space;
|
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
|
-- Start of processing for Scan_ALI
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
@ -706,6 +721,8 @@ package body ALI is
|
||||||
Normalize_Scalars_Specified := True;
|
Normalize_Scalars_Specified := True;
|
||||||
NS_Found := True;
|
NS_Found := True;
|
||||||
|
|
||||||
|
-- Invalid switch starting with N
|
||||||
|
|
||||||
else
|
else
|
||||||
Fatal_Error;
|
Fatal_Error;
|
||||||
end if;
|
end if;
|
||||||
|
@ -716,11 +733,26 @@ package body ALI is
|
||||||
Queuing_Policy_Specified := Getc;
|
Queuing_Policy_Specified := Getc;
|
||||||
ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified;
|
ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified;
|
||||||
|
|
||||||
-- Processing for SL
|
-- Processing fir flags starting with S
|
||||||
|
|
||||||
elsif C = 'S' then
|
elsif C = 'S' then
|
||||||
Checkc ('L');
|
C := Getc;
|
||||||
ALIs.Table (Id).Interface := True;
|
|
||||||
|
-- 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
|
-- Processing for Tx
|
||||||
|
|
||||||
|
@ -729,18 +761,25 @@ package body ALI is
|
||||||
ALIs.Table (Id).Task_Dispatching_Policy :=
|
ALIs.Table (Id).Task_Dispatching_Policy :=
|
||||||
Task_Dispatching_Policy_Specified;
|
Task_Dispatching_Policy_Specified;
|
||||||
|
|
||||||
-- Processing for UA
|
-- Processing for switch starting with U
|
||||||
|
|
||||||
elsif C = 'U' then
|
elsif C = 'U' then
|
||||||
if Nextc = 'A' then
|
C := Getc;
|
||||||
|
|
||||||
|
-- Processing for UA
|
||||||
|
|
||||||
|
if C = 'A' then
|
||||||
Unreserve_All_Interrupts_Specified := True;
|
Unreserve_All_Interrupts_Specified := True;
|
||||||
C := Getc;
|
|
||||||
|
|
||||||
-- Processing for UX
|
-- Processing for UX
|
||||||
|
|
||||||
else
|
elsif C = 'X' then
|
||||||
Checkc ('X');
|
|
||||||
ALIs.Table (Id).Unit_Exception_Table := True;
|
ALIs.Table (Id).Unit_Exception_Table := True;
|
||||||
|
|
||||||
|
-- Invalid switches starting with U
|
||||||
|
|
||||||
|
else
|
||||||
|
Fatal_Error;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- Processing for ZX
|
-- Processing for ZX
|
||||||
|
@ -1487,11 +1526,9 @@ package body ALI is
|
||||||
Xref_Entity.Increment_Last;
|
Xref_Entity.Increment_Last;
|
||||||
|
|
||||||
Read_Refs_For_One_Entity : declare
|
Read_Refs_For_One_Entity : declare
|
||||||
|
|
||||||
XE : Xref_Entity_Record renames
|
XE : Xref_Entity_Record renames
|
||||||
Xref_Entity.Table (Xref_Entity.Last);
|
Xref_Entity.Table (Xref_Entity.Last);
|
||||||
|
N : Nat;
|
||||||
N : Nat;
|
|
||||||
|
|
||||||
procedure Read_Instantiation_Reference;
|
procedure Read_Instantiation_Reference;
|
||||||
-- Acquire instantiation reference. Caller has checked
|
-- Acquire instantiation reference. Caller has checked
|
||||||
|
@ -1621,7 +1658,6 @@ package body ALI is
|
||||||
|
|
||||||
declare
|
declare
|
||||||
Nested_Brackets : Natural := 0;
|
Nested_Brackets : Natural := 0;
|
||||||
C : Character;
|
|
||||||
|
|
||||||
begin
|
begin
|
||||||
loop
|
loop
|
||||||
|
@ -1636,7 +1672,7 @@ package body ALI is
|
||||||
end if;
|
end if;
|
||||||
end case;
|
end case;
|
||||||
|
|
||||||
C := Getc;
|
Skipc;
|
||||||
end loop;
|
end loop;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
@ -1680,7 +1716,6 @@ package body ALI is
|
||||||
Current_File_Num := XR.File_Num;
|
Current_File_Num := XR.File_Num;
|
||||||
P := P + 1;
|
P := P + 1;
|
||||||
N := Get_Nat;
|
N := Get_Nat;
|
||||||
|
|
||||||
else
|
else
|
||||||
XR.File_Num := Current_File_Num;
|
XR.File_Num := Current_File_Num;
|
||||||
end if;
|
end if;
|
||||||
|
@ -1710,7 +1745,6 @@ package body ALI is
|
||||||
|
|
||||||
XE.Last_Xref := Xref.Last;
|
XE.Last_Xref := Xref.Last;
|
||||||
C := Nextc;
|
C := Nextc;
|
||||||
|
|
||||||
end Read_Refs_For_One_Entity;
|
end Read_Refs_For_One_Entity;
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -518,9 +518,10 @@ package body Bindgen is
|
||||||
Write_Statement_Buffer;
|
Write_Statement_Buffer;
|
||||||
|
|
||||||
-- Generate call to Install_Handler
|
-- Generate call to Install_Handler
|
||||||
|
|
||||||
WBI ("");
|
WBI ("");
|
||||||
WBI (" if Handler_Installed = 0 then");
|
WBI (" if Handler_Installed = 0 then");
|
||||||
WBI (" Install_Handler;");
|
WBI (" Install_Handler;");
|
||||||
WBI (" end if;");
|
WBI (" end if;");
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
@ -536,6 +537,17 @@ package body Bindgen is
|
||||||
Write_Statement_Buffer;
|
Write_Statement_Buffer;
|
||||||
end if;
|
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
|
-- Generate elaboration calls
|
||||||
|
|
||||||
WBI ("");
|
WBI ("");
|
||||||
|
@ -613,6 +625,13 @@ package body Bindgen is
|
||||||
Set_String (""";");
|
Set_String (""";");
|
||||||
Write_Statement_Buffer;
|
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 ("");
|
WBI ("");
|
||||||
|
|
||||||
-- Code for normal case (standard library not suppressed)
|
-- Code for normal case (standard library not suppressed)
|
||||||
|
@ -742,6 +761,17 @@ package body Bindgen is
|
||||||
Write_Statement_Buffer;
|
Write_Statement_Buffer;
|
||||||
end if;
|
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
|
-- Generate elaboration calls
|
||||||
|
|
||||||
WBI ("");
|
WBI ("");
|
||||||
|
@ -1862,12 +1892,24 @@ package body Bindgen is
|
||||||
|
|
||||||
if With_GNARL then
|
if With_GNARL then
|
||||||
Name_Len := 0;
|
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;
|
Write_Linker_Option;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
Name_Len := 0;
|
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;
|
Write_Linker_Option;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
@ -1983,6 +2025,12 @@ package body Bindgen is
|
||||||
WBI ("with System.Scalar_Values;");
|
WBI ("with System.Scalar_Values;");
|
||||||
end if;
|
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;
|
Resolve_Binder_Options;
|
||||||
|
|
||||||
if not Suppress_Standard_Library_On_Target then
|
if not Suppress_Standard_Library_On_Target then
|
||||||
|
@ -2698,7 +2746,6 @@ package body Bindgen is
|
||||||
----------------------------
|
----------------------------
|
||||||
|
|
||||||
procedure Public_Version_Warning is
|
procedure Public_Version_Warning is
|
||||||
|
|
||||||
Time : constant Int := Time_From_Last_Bind;
|
Time : constant Int := Time_From_Last_Bind;
|
||||||
|
|
||||||
-- Constants to help defining periods
|
-- 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
|
-- Do not emit the message if the last message was emitted in the
|
||||||
-- specified period taking into account the number of units.
|
-- 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
|
if Nb_Unit < Large and then Time <= Period_Small then
|
||||||
return;
|
return;
|
||||||
|
|
||||||
elsif Time <= Period_Large then
|
elsif Time <= Period_Large then
|
||||||
return;
|
return;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
pragma Warnings (On);
|
||||||
|
|
||||||
Write_Eol;
|
Write_Eol;
|
||||||
Write_Str ("IMPORTANT NOTICE:");
|
Write_Str ("IMPORTANT NOTICE:");
|
||||||
Write_Eol;
|
Write_Eol;
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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_Str (" -C Generate binder program in C");
|
||||||
Write_Eol;
|
Write_Eol;
|
||||||
|
|
||||||
|
-- Line for D switch
|
||||||
|
|
||||||
|
Write_Str (" -Dnnn Default secondary stack size = nnn bytes");
|
||||||
|
Write_Eol;
|
||||||
|
|
||||||
-- Line for -e switch
|
-- Line for -e switch
|
||||||
|
|
||||||
Write_Str (" -e Output complete list of elabor");
|
Write_Str (" -e Output complete list of elabor");
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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;
|
Copyright_Displayed : Boolean := False;
|
||||||
-- To avoid displaying the Copyright line several times
|
-- To avoid displaying the Copyright line several times
|
||||||
|
|
||||||
Usage_Displayed : Boolean := False;
|
Usage_Displayed : Boolean := False;
|
||||||
-- To avoid displaying the usage several times
|
-- To avoid displaying the usage several times
|
||||||
|
|
||||||
type Expression_Kind_Type is (Undecided, Static_String, Other);
|
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
|
-- After procedure Expression has been called, this global variable
|
||||||
-- indicates if the expression is a static string or not.
|
-- indicates if the expression is a static string or not.
|
||||||
-- If it is a static string, then Expression_Value (1 .. Expression_Last)
|
-- 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
|
-- The following variables are used to controlled what attributes
|
||||||
-- Default_Switches and Switches are allowed in expressions.
|
-- 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_Package : Name_Id := No_Name;
|
Default_Switches_Language : Name_Id := No_Name;
|
||||||
Default_Switches_Language : Name_Id := No_Name;
|
|
||||||
|
|
||||||
Switches_Project : Project_Node_Id := Empty_Node;
|
|
||||||
Switches_Package : Name_Id := No_Name;
|
Switches_Package : Name_Id := No_Name;
|
||||||
Switches_Language : Source_Kind_Type := Unknown;
|
Switches_Language : Source_Kind_Type := Unknown;
|
||||||
|
|
||||||
-- Other attribute references are only allowed in attribute declarations
|
-- Other attribute references are only allowed in attribute declarations
|
||||||
-- of the same package and of the same name.
|
-- of the same package and of the same name.
|
||||||
|
|
||||||
-- Other_Attribute is True only during attribute declarations other than
|
-- Other_Attribute is True only during attribute declarations other than
|
||||||
-- Switches or Default_Switches.
|
-- Switches or Default_Switches.
|
||||||
|
|
||||||
|
@ -383,8 +381,7 @@ package body Bld is
|
||||||
(Static : Boolean;
|
(Static : Boolean;
|
||||||
Value : String_Access;
|
Value : String_Access;
|
||||||
Last : Natural;
|
Last : Natural;
|
||||||
Default : String)
|
Default : String) return String;
|
||||||
return String;
|
|
||||||
-- Returns the current suffix, if it is statically known, or ""
|
-- Returns the current suffix, if it is statically known, or ""
|
||||||
-- if it is not statically known. Used on C_Suffix, Cxx_Suffix,
|
-- if it is not statically known. Used on C_Suffix, Cxx_Suffix,
|
||||||
-- Ada_Body_Suffix and Ada_Spec_Suffix.
|
-- Ada_Body_Suffix and Ada_Spec_Suffix.
|
||||||
|
@ -435,7 +432,7 @@ package body Bld is
|
||||||
Copyright_Displayed := True;
|
Copyright_Displayed := True;
|
||||||
Write_Str ("GPR2MAKE ");
|
Write_Str ("GPR2MAKE ");
|
||||||
Write_Str (Gnatvsn.Gnat_Version_String);
|
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;
|
||||||
Write_Eol;
|
Write_Eol;
|
||||||
end if;
|
end if;
|
||||||
|
@ -1175,12 +1172,10 @@ package body Bld is
|
||||||
Current_Declarative_Item := Next_Declarative_Item
|
Current_Declarative_Item := Next_Declarative_Item
|
||||||
(Current_Declarative_Item);
|
(Current_Declarative_Item);
|
||||||
|
|
||||||
-- By default, indicate that Default_Switches and Switches
|
-- By default, indicate that we are not declaring attribute
|
||||||
-- attribute references are not allowed in expressions.
|
-- Default_Switches or Switches.
|
||||||
|
|
||||||
Default_Switches_Project := Empty_Node;
|
Other_Attribute := False;
|
||||||
Switches_Project := Empty_Node;
|
|
||||||
Other_Attribute := False;
|
|
||||||
|
|
||||||
-- Write_Line (Project_Node_Kind'Image (Kind_Of (Current_Item)));
|
-- Write_Line (Project_Node_Kind'Image (Kind_Of (Current_Item)));
|
||||||
|
|
||||||
|
@ -1345,7 +1340,6 @@ package body Bld is
|
||||||
-- in expressions.
|
-- in expressions.
|
||||||
|
|
||||||
if Item_Name = Snames.Name_Default_Switches then
|
if Item_Name = Snames.Name_Default_Switches then
|
||||||
Default_Switches_Project := Project;
|
|
||||||
Default_Switches_Package := Pkg;
|
Default_Switches_Package := Pkg;
|
||||||
Default_Switches_Language := Index;
|
Default_Switches_Language := Index;
|
||||||
|
|
||||||
|
@ -1354,7 +1348,6 @@ package body Bld is
|
||||||
-- Switches attribute references are allowed in expressions.
|
-- Switches attribute references are allowed in expressions.
|
||||||
|
|
||||||
elsif Item_Name = Snames.Name_Switches then
|
elsif Item_Name = Snames.Name_Switches then
|
||||||
Switches_Project := Project;
|
|
||||||
Switches_Package := Pkg;
|
Switches_Package := Pkg;
|
||||||
Switches_Language := Source_Kind_Of (Index);
|
Switches_Language := Source_Kind_Of (Index);
|
||||||
|
|
||||||
|
@ -1862,7 +1855,7 @@ package body Bld is
|
||||||
end if;
|
end if;
|
||||||
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
|
-- For "Ada", we set the variable ADA_BODY
|
||||||
|
|
||||||
|
@ -1897,9 +1890,9 @@ package body Bld is
|
||||||
else
|
else
|
||||||
Ada_Body_Suffix_Static :=
|
Ada_Body_Suffix_Static :=
|
||||||
Expression_Value
|
Expression_Value
|
||||||
(1 .. Expression_Last) =
|
(1 .. Expression_Last) =
|
||||||
Ada_Body_Suffix
|
Ada_Body_Suffix
|
||||||
(1 .. Ada_Body_Suffix_Last);
|
(1 .. Ada_Body_Suffix_Last);
|
||||||
end if;
|
end if;
|
||||||
end if;
|
end if;
|
||||||
end if;
|
end if;
|
||||||
|
@ -3511,8 +3504,7 @@ package body Bld is
|
||||||
(Static : Boolean;
|
(Static : Boolean;
|
||||||
Value : String_Access;
|
Value : String_Access;
|
||||||
Last : Natural;
|
Last : Natural;
|
||||||
Default : String)
|
Default : String) return String
|
||||||
return String
|
|
||||||
is
|
is
|
||||||
begin
|
begin
|
||||||
if Static then
|
if Static then
|
||||||
|
|
|
@ -463,13 +463,16 @@ package body Checks is
|
||||||
Expr : Node_Id;
|
Expr : Node_Id;
|
||||||
Loc : Source_Ptr;
|
Loc : Source_Ptr;
|
||||||
|
|
||||||
|
Alignment_Required : constant Boolean := Maximum_Alignment > 1;
|
||||||
|
-- Constant to show whether target requires alignment checks
|
||||||
|
|
||||||
begin
|
begin
|
||||||
-- See if check needed. Note that we never need a check if the
|
-- See if check needed. Note that we never need a check if the
|
||||||
-- maximum alignment is one, since the check will always succeed
|
-- maximum alignment is one, since the check will always succeed
|
||||||
|
|
||||||
if No (AC)
|
if No (AC)
|
||||||
or else not Check_Address_Alignment (AC)
|
or else not Check_Address_Alignment (AC)
|
||||||
or else Maximum_Alignment = 1
|
or else not Alignment_Required
|
||||||
then
|
then
|
||||||
return;
|
return;
|
||||||
end if;
|
end if;
|
||||||
|
@ -1191,7 +1194,7 @@ package body Checks is
|
||||||
N_Full_Type_Declaration
|
N_Full_Type_Declaration
|
||||||
then
|
then
|
||||||
declare
|
declare
|
||||||
Type_Def : Node_Id :=
|
Type_Def : constant Node_Id :=
|
||||||
Type_Definition
|
Type_Definition
|
||||||
(Original_Node (Parent (T_Typ)));
|
(Original_Node (Parent (T_Typ)));
|
||||||
begin
|
begin
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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;
|
Source_File : File_Name_Type;
|
||||||
-- Current source file
|
-- Current source file
|
||||||
|
|
||||||
Full_Source_File : File_Name_Type;
|
|
||||||
-- Full name of the current source file
|
|
||||||
|
|
||||||
Lib_File : File_Name_Type;
|
Lib_File : File_Name_Type;
|
||||||
-- Current library file
|
-- Current library file
|
||||||
|
|
||||||
|
@ -401,9 +398,8 @@ package body Clean is
|
||||||
while not Empty_Q loop
|
while not Empty_Q loop
|
||||||
Sources.Set_Last (0);
|
Sources.Set_Last (0);
|
||||||
Extract_From_Q (Source_File);
|
Extract_From_Q (Source_File);
|
||||||
Full_Source_File := Osint.Full_Source_Name (Source_File);
|
Lib_File := Osint.Lib_File_Name (Source_File);
|
||||||
Lib_File := Osint.Lib_File_Name (Source_File);
|
Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File);
|
||||||
Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File);
|
|
||||||
|
|
||||||
-- If we have an existing ALI file that is not read-only,
|
-- If we have an existing ALI file that is not read-only,
|
||||||
-- process it.
|
-- process it.
|
||||||
|
@ -925,7 +921,7 @@ package body Clean is
|
||||||
if not Copyright_Displayed then
|
if not Copyright_Displayed then
|
||||||
Copyright_Displayed := True;
|
Copyright_Displayed := True;
|
||||||
Put_Line ("GNATCLEAN " & Gnatvsn.Gnat_Version_String
|
Put_Line ("GNATCLEAN " & Gnatvsn.Gnat_Version_String
|
||||||
& " Copyright 2003 Free Software Foundation, Inc.");
|
& " Copyright 2003-2004 Free Software Foundation, Inc.");
|
||||||
end if;
|
end if;
|
||||||
end Display_Copyright;
|
end Display_Copyright;
|
||||||
|
|
||||||
|
@ -1156,9 +1152,7 @@ package body Clean is
|
||||||
-- Insert_Q --
|
-- Insert_Q --
|
||||||
--------------
|
--------------
|
||||||
|
|
||||||
procedure Insert_Q
|
procedure Insert_Q (Source_File : File_Name_Type) is
|
||||||
(Source_File : File_Name_Type)
|
|
||||||
is
|
|
||||||
begin
|
begin
|
||||||
-- Do not insert an empty name or an already marked source
|
-- 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
|
function Object_File_Name (Source : Name_Id) return String is
|
||||||
Src : constant String := Get_Name_String (Source);
|
Src : constant String := Get_Name_String (Source);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
-- If the source name has an extension, then replace it with
|
-- If the source name has an extension, then replace it with
|
||||||
-- the Object suffix.
|
-- the Object suffix.
|
||||||
|
|
|
@ -258,10 +258,10 @@ package body CStand is
|
||||||
-- by Initialize_Standard in the semantics module.
|
-- by Initialize_Standard in the semantics module.
|
||||||
|
|
||||||
procedure Create_Standard is
|
procedure Create_Standard is
|
||||||
Decl_S : List_Id := New_List;
|
Decl_S : constant List_Id := New_List;
|
||||||
-- List of declarations in Standard
|
-- List of declarations in Standard
|
||||||
|
|
||||||
Decl_A : List_Id := New_List;
|
Decl_A : constant List_Id := New_List;
|
||||||
-- List of declarations in ASCII
|
-- List of declarations in ASCII
|
||||||
|
|
||||||
Decl : Node_Id;
|
Decl : Node_Id;
|
||||||
|
|
|
@ -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
|
each. While doing this, build a copy-out structure if
|
||||||
we need one. */
|
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;
|
for (gnat_param = First_Formal (gnat_entity), parmnum = 0;
|
||||||
Present (gnat_param);
|
Present (gnat_param);
|
||||||
gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
|
gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
|
||||||
|
|
|
@ -4660,7 +4660,7 @@ package body Einfo is
|
||||||
end Entry_Index_Type;
|
end Entry_Index_Type;
|
||||||
|
|
||||||
---------------------
|
---------------------
|
||||||
-- First_Component --
|
-- 1 --
|
||||||
---------------------
|
---------------------
|
||||||
|
|
||||||
function First_Component (Id : E) return E is
|
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));
|
(Is_Record_Type (Id) or else Is_Incomplete_Or_Private_Type (Id));
|
||||||
|
|
||||||
Comp_Id := First_Entity (Id);
|
Comp_Id := First_Entity (Id);
|
||||||
|
|
||||||
while Present (Comp_Id) loop
|
while Present (Comp_Id) loop
|
||||||
exit when Ekind (Comp_Id) = E_Component;
|
exit when Ekind (Comp_Id) = E_Component;
|
||||||
Comp_Id := Next_Entity (Comp_Id);
|
Comp_Id := Next_Entity (Comp_Id);
|
||||||
|
|
|
@ -521,7 +521,7 @@ package Einfo is
|
||||||
-- representation clause is present for the corresponding record
|
-- representation clause is present for the corresponding record
|
||||||
-- type a that specifies a position for the component, then the
|
-- type a that specifies a position for the component, then the
|
||||||
-- Component_Clause field of the E_Component entity points to 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
|
-- clause was present, or if there was no specification for this
|
||||||
-- component.
|
-- component.
|
||||||
|
|
||||||
|
@ -2581,6 +2581,7 @@ package Einfo is
|
||||||
-- Present in components and discriminants. Indicates the normalized
|
-- Present in components and discriminants. Indicates the normalized
|
||||||
-- value of First_Bit for the component, i.e. the offset within the
|
-- value of First_Bit for the component, i.e. the offset within the
|
||||||
-- lowest addressed storage unit containing part or all of the field.
|
-- 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)
|
-- Normalized_Position (Uint14)
|
||||||
-- Present in components and discriminants. Indicates the normalized
|
-- Present in components and discriminants. Indicates the normalized
|
||||||
|
|
|
@ -264,6 +264,8 @@ package body Exp_Aggr is
|
||||||
-- 5. The array component type is tagged, which may necessitate
|
-- 5. The array component type is tagged, which may necessitate
|
||||||
-- reassignment of proper tags.
|
-- reassignment of proper tags.
|
||||||
|
|
||||||
|
-- 6. The array component type might have unaligned bit components
|
||||||
|
|
||||||
function Backend_Processing_Possible (N : Node_Id) return Boolean is
|
function Backend_Processing_Possible (N : Node_Id) return Boolean is
|
||||||
Typ : constant Entity_Id := Etype (N);
|
Typ : constant Entity_Id := Etype (N);
|
||||||
-- Typ is the correct constrained array subtype of the aggregate.
|
-- Typ is the correct constrained array subtype of the aggregate.
|
||||||
|
@ -317,7 +319,7 @@ package body Exp_Aggr is
|
||||||
return False;
|
return False;
|
||||||
end if;
|
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
|
if Convention (Typ) = Convention_Fortran
|
||||||
and then Number_Dimensions (Typ) > 1
|
and then Number_Dimensions (Typ) > 1
|
||||||
|
@ -350,6 +352,12 @@ package body Exp_Aggr is
|
||||||
return False;
|
return False;
|
||||||
end if;
|
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
|
-- Backend processing is possible
|
||||||
|
|
||||||
Set_Compile_Time_Known_Aggregate (N, True);
|
Set_Compile_Time_Known_Aggregate (N, True);
|
||||||
|
@ -1924,7 +1932,7 @@ package body Exp_Aggr is
|
||||||
-- by Build_Task_Allocate_Block_With_Init_Stmts)
|
-- by Build_Task_Allocate_Block_With_Init_Stmts)
|
||||||
|
|
||||||
declare
|
declare
|
||||||
Ctype : Entity_Id := Etype (Selector);
|
Ctype : constant Entity_Id := Etype (Selector);
|
||||||
Inside_Allocator : Boolean := False;
|
Inside_Allocator : Boolean := False;
|
||||||
P : Node_Id := Parent (N);
|
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
|
function Must_Slide (N : Node_Id; Typ : Entity_Id) return Boolean
|
||||||
is
|
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;
|
L1, L2, H1, H2 : Node_Id;
|
||||||
|
|
||||||
|
@ -4343,6 +4352,12 @@ package body Exp_Aggr is
|
||||||
elsif Has_Mutable_Components (Typ) then
|
elsif Has_Mutable_Components (Typ) then
|
||||||
Convert_To_Assignments (N, Typ);
|
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
|
-- In all other cases we generate a proper aggregate that
|
||||||
-- can be handled by gigi.
|
-- can be handled by gigi.
|
||||||
|
|
||||||
|
|
|
@ -721,7 +721,7 @@ package body Exp_Ch11 is
|
||||||
|
|
||||||
if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then
|
if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then
|
||||||
declare
|
declare
|
||||||
H : Node_Id := Handler;
|
H : constant Node_Id := Handler;
|
||||||
begin
|
begin
|
||||||
Next_Non_Pragma (Handler);
|
Next_Non_Pragma (Handler);
|
||||||
Remove (H);
|
Remove (H);
|
||||||
|
|
|
@ -2882,7 +2882,7 @@ package body Exp_Ch3 is
|
||||||
|
|
||||||
begin
|
begin
|
||||||
-- Don't do anything for deferred constants. All proper actions will
|
-- 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
|
if No (Expr) and Constant_Present (N) then
|
||||||
return;
|
return;
|
||||||
|
@ -3018,7 +3018,7 @@ package body Exp_Ch3 is
|
||||||
-- When we have the appropriate type of aggregate in the
|
-- When we have the appropriate type of aggregate in the
|
||||||
-- expression (it has been determined during analysis of the
|
-- expression (it has been determined during analysis of the
|
||||||
-- aggregate by setting the delay flag), let's perform in
|
-- 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
|
if Is_Delayed_Aggregate (Expr_Q) then
|
||||||
Convert_Aggr_In_Object_Decl (N);
|
Convert_Aggr_In_Object_Decl (N);
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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;
|
Comp : RE_Id;
|
||||||
|
|
||||||
|
Stg_Unit_Is_Byte : constant Boolean := System_Storage_Unit = Byte'Size;
|
||||||
|
|
||||||
function Length_Less_Than_4 (Opnd : Node_Id) return Boolean;
|
function Length_Less_Than_4 (Opnd : Node_Id) return Boolean;
|
||||||
-- Returns True if the length of the given operand is known to be
|
-- 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
|
-- 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.
|
-- addressing of array components.
|
||||||
|
|
||||||
if not Is_Bit_Packed_Array (Typ1)
|
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
|
and then not Java_VM
|
||||||
then
|
then
|
||||||
-- The call we generate is:
|
-- The call we generate is:
|
||||||
|
@ -5471,8 +5473,8 @@ package body Exp_Ch4 is
|
||||||
then
|
then
|
||||||
return;
|
return;
|
||||||
|
|
||||||
elsif (Nkind (Parent (N)) = N_Attribute_Reference
|
elsif Nkind (Parent (N)) = N_Attribute_Reference
|
||||||
and then Attribute_Name (Parent (N)) = Name_Address)
|
and then Attribute_Name (Parent (N)) = Name_Address
|
||||||
then
|
then
|
||||||
return;
|
return;
|
||||||
|
|
||||||
|
|
|
@ -48,6 +48,7 @@ with Sem_Res; use Sem_Res;
|
||||||
with Sem_Util; use Sem_Util;
|
with Sem_Util; use Sem_Util;
|
||||||
with Snames; use Snames;
|
with Snames; use Snames;
|
||||||
with Stand; use Stand;
|
with Stand; use Stand;
|
||||||
|
with Stringt; use Stringt;
|
||||||
with Tbuild; use Tbuild;
|
with Tbuild; use Tbuild;
|
||||||
with Ttypes; use Ttypes;
|
with Ttypes; use Ttypes;
|
||||||
with Uintp; use Uintp;
|
with Uintp; use Uintp;
|
||||||
|
@ -75,8 +76,7 @@ package body Exp_Ch5 is
|
||||||
L_Type : Entity_Id;
|
L_Type : Entity_Id;
|
||||||
R_Type : Entity_Id;
|
R_Type : Entity_Id;
|
||||||
Ndim : Pos;
|
Ndim : Pos;
|
||||||
Rev : Boolean)
|
Rev : Boolean) return Node_Id;
|
||||||
return Node_Id;
|
|
||||||
-- N is an assignment statement which assigns an array value. This routine
|
-- 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
|
-- expands the assignment into a loop (or nested loops for the case of a
|
||||||
-- multi-dimensional array) to do the assignment component by component.
|
-- 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;
|
function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean;
|
||||||
-- This function is used in processing the assignment of a record or
|
-- This function is used in processing the assignment of a record or
|
||||||
-- indexed component. The back end can handle such assignments fine
|
-- indexed component. The argument N is either the left hand or right
|
||||||
-- if the objects involved are small (64-bits or less) records or
|
-- hand side of an assignment, and this function determines if there
|
||||||
-- scalar items (including bit-packed arrays represented with modular
|
-- is a record component reference where the record may be bit aligned
|
||||||
-- types) or are both aligned on a byte boundary (starting on a byte
|
-- in a manner that causes trouble for the back end (see description
|
||||||
-- boundary, and occupying an integral number of bytes).
|
-- of Sem_Util.Component_May_Be_Bit_Aligned for further details).
|
||||||
--
|
|
||||||
-- 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.
|
|
||||||
|
|
||||||
------------------------------
|
------------------------------
|
||||||
-- Change_Of_Representation --
|
-- Change_Of_Representation --
|
||||||
|
@ -508,9 +487,12 @@ package body Exp_Ch5 is
|
||||||
-- statement, a length check has already been emitted to verify that
|
-- statement, a length check has already been emitted to verify that
|
||||||
-- the range of the left-hand side is empty.
|
-- 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
|
elsif Nkind (Rhs) = N_String_Literal then
|
||||||
if Ekind (R_Type) = E_String_Literal_Subtype
|
if String_Length (Strval (Rhs)) = 0
|
||||||
and then String_Literal_Length (R_Type) = 0
|
|
||||||
and then Is_Bit_Packed_Array (L_Type)
|
and then Is_Bit_Packed_Array (L_Type)
|
||||||
then
|
then
|
||||||
Rewrite (N, Make_Null_Statement (Loc));
|
Rewrite (N, Make_Null_Statement (Loc));
|
||||||
|
@ -731,8 +713,8 @@ package body Exp_Ch5 is
|
||||||
|
|
||||||
elsif Restrictions (No_Implicit_Conditionals) then
|
elsif Restrictions (No_Implicit_Conditionals) then
|
||||||
declare
|
declare
|
||||||
T : constant Entity_Id := Make_Defining_Identifier (Loc,
|
T : constant Entity_Id :=
|
||||||
Chars => Name_T);
|
Make_Defining_Identifier (Loc, Chars => Name_T);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Rewrite (N,
|
Rewrite (N,
|
||||||
|
@ -881,8 +863,7 @@ package body Exp_Ch5 is
|
||||||
L_Type : Entity_Id;
|
L_Type : Entity_Id;
|
||||||
R_Type : Entity_Id;
|
R_Type : Entity_Id;
|
||||||
Ndim : Pos;
|
Ndim : Pos;
|
||||||
Rev : Boolean)
|
Rev : Boolean) return Node_Id
|
||||||
return Node_Id
|
|
||||||
is
|
is
|
||||||
Loc : constant Source_Ptr := Sloc (N);
|
Loc : constant Source_Ptr := Sloc (N);
|
||||||
|
|
||||||
|
@ -2244,8 +2225,8 @@ package body Exp_Ch5 is
|
||||||
and then List_Length (Else_Statements (N)) = 1
|
and then List_Length (Else_Statements (N)) = 1
|
||||||
then
|
then
|
||||||
declare
|
declare
|
||||||
Then_Stm : Node_Id := First (Then_Statements (N));
|
Then_Stm : constant Node_Id := First (Then_Statements (N));
|
||||||
Else_Stm : Node_Id := First (Else_Statements (N));
|
Else_Stm : constant Node_Id := First (Else_Statements (N));
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if Nkind (Then_Stm) = N_Return_Statement
|
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
|
-- unless it is forced to do so. In the clear means we need
|
||||||
-- only the recursive test on the prefix.
|
-- only the recursive test on the prefix.
|
||||||
|
|
||||||
if No (Component_Clause (Comp)) then
|
if Component_May_Be_Bit_Aligned (Comp) then
|
||||||
return Possible_Bit_Aligned_Component (P);
|
return True;
|
||||||
|
|
||||||
-- 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.
|
|
||||||
|
|
||||||
else
|
else
|
||||||
-- If we know that we have a small (64 bits or less) record
|
return Possible_Bit_Aligned_Component (P);
|
||||||
-- 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;
|
|
||||||
end if;
|
end if;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
|
|
@ -59,7 +59,6 @@ with Sem_Ch12; use Sem_Ch12;
|
||||||
with Sem_Ch13; use Sem_Ch13;
|
with Sem_Ch13; use Sem_Ch13;
|
||||||
with Sem_Disp; use Sem_Disp;
|
with Sem_Disp; use Sem_Disp;
|
||||||
with Sem_Dist; use Sem_Dist;
|
with Sem_Dist; use Sem_Dist;
|
||||||
with Sem_Eval; use Sem_Eval;
|
|
||||||
with Sem_Res; use Sem_Res;
|
with Sem_Res; use Sem_Res;
|
||||||
with Sem_Util; use Sem_Util;
|
with Sem_Util; use Sem_Util;
|
||||||
with Sinfo; use Sinfo;
|
with Sinfo; use Sinfo;
|
||||||
|
@ -2989,10 +2988,7 @@ package body Exp_Ch6 is
|
||||||
Expression (Last (Pragma_Argument_Associations (TB_Pragma)));
|
Expression (Last (Pragma_Argument_Associations (TB_Pragma)));
|
||||||
else
|
else
|
||||||
Sec_Stack_Len :=
|
Sec_Stack_Len :=
|
||||||
Make_Integer_Literal (Loc,
|
New_Occurrence_Of (RTE (RE_Default_Secondary_Stack_Size), Loc);
|
||||||
Intval =>
|
|
||||||
Expr_Value
|
|
||||||
(Constant_Value (RTE (RE_Default_Secondary_Stack_Size))));
|
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
Sec_Stack_Len := Convert_To (RTE (RE_Storage_Offset), Sec_Stack_Len);
|
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
|
-- If this is a Pure function which has any parameters whose root
|
||||||
-- type is System.Address, reset the Pure indication, since it will
|
-- 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)
|
if Is_Pure (Spec_Id)
|
||||||
and then Is_Subprogram (Spec_Id)
|
and then Is_Subprogram (Spec_Id)
|
||||||
|
|
|
@ -508,7 +508,7 @@ package body Exp_Ch7 is
|
||||||
return List_Id
|
return List_Id
|
||||||
is
|
is
|
||||||
Loc : constant Source_Ptr := Sloc (N);
|
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;
|
function Free_Component return List_Id;
|
||||||
-- Generate the code to finalize the task or protected subcomponents
|
-- 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
|
function Free_Component return List_Id is
|
||||||
Stmts : List_Id := New_List;
|
Stmts : List_Id := New_List;
|
||||||
Tsk : Node_Id;
|
Tsk : Node_Id;
|
||||||
C_Typ : Entity_Id := Component_Type (Typ);
|
C_Typ : constant Entity_Id := Component_Type (Typ);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
-- Component type is known to contain tasks or protected objects
|
-- 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);
|
Loc : constant Source_Ptr := Sloc (N);
|
||||||
Tsk : Node_Id;
|
Tsk : Node_Id;
|
||||||
Comp : Entity_Id;
|
Comp : Entity_Id;
|
||||||
Stmts : List_Id := New_List;
|
Stmts : constant List_Id := New_List;
|
||||||
U_Typ : constant Entity_Id := Underlying_Type (Typ);
|
U_Typ : constant Entity_Id := Underlying_Type (Typ);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if Has_Discriminants (U_Typ)
|
if Has_Discriminants (U_Typ)
|
||||||
|
@ -696,13 +696,12 @@ package body Exp_Ch7 is
|
||||||
------------------------------------
|
------------------------------------
|
||||||
|
|
||||||
procedure Clean_Simple_Protected_Objects (N : Node_Id) 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;
|
E : Entity_Id;
|
||||||
Stmts : List_Id := Statements (Handled_Statement_Sequence (N));
|
|
||||||
Stmt : Node_Id := Last (Stmts);
|
|
||||||
|
|
||||||
begin
|
begin
|
||||||
E := First_Entity (Current_Scope);
|
E := First_Entity (Current_Scope);
|
||||||
|
|
||||||
while Present (E) loop
|
while Present (E) loop
|
||||||
if (Ekind (E) = E_Variable
|
if (Ekind (E) = E_Variable
|
||||||
or else Ekind (E) = E_Constant)
|
or else Ekind (E) = E_Constant)
|
||||||
|
|
|
@ -8211,14 +8211,13 @@ package body Exp_Ch9 is
|
||||||
and then Chars (Ritem) = Name_Attach_Handler
|
and then Chars (Ritem) = Name_Attach_Handler
|
||||||
then
|
then
|
||||||
declare
|
declare
|
||||||
Handler : constant Node_Id :=
|
Handler : constant Node_Id :=
|
||||||
First (Pragma_Argument_Associations (Ritem));
|
First (Pragma_Argument_Associations (Ritem));
|
||||||
Interrupt : constant Node_Id :=
|
|
||||||
Next (Handler);
|
Interrupt : constant Node_Id := Next (Handler);
|
||||||
Expr : Node_Id := Expression (Interrupt);
|
Expr : constant Node_Id := Expression (Interrupt);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
|
||||||
Append_To (Table,
|
Append_To (Table,
|
||||||
Make_Aggregate (Loc, Expressions => New_List (
|
Make_Aggregate (Loc, Expressions => New_List (
|
||||||
Unchecked_Convert_To
|
Unchecked_Convert_To
|
||||||
|
|
|
@ -898,6 +898,52 @@ package body Exp_Util is
|
||||||
return Build_Task_Image_Function (Loc, Decls, Stats, Res);
|
return Build_Task_Image_Function (Loc, Decls, Stats, Res);
|
||||||
end Build_Task_Record_Image;
|
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 --
|
-- Convert_To_Actual_Subtype --
|
||||||
-------------------------------
|
-------------------------------
|
||||||
|
@ -3877,6 +3923,53 @@ package body Exp_Util is
|
||||||
and then Esize (Left_Typ) = Esize (Result_Typ);
|
and then Esize (Left_Typ) = Esize (Result_Typ);
|
||||||
end Target_Has_Fixed_Ops;
|
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 --
|
-- Wrap_Cleanup_Procedure --
|
||||||
----------------------------
|
----------------------------
|
||||||
|
|
|
@ -208,6 +208,36 @@ package Exp_Util is
|
||||||
-- computes the image without using concatenation, and one for the
|
-- computes the image without using concatenation, and one for the
|
||||||
-- variable that holds the result.
|
-- 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);
|
procedure Convert_To_Actual_Subtype (Exp : Node_Id);
|
||||||
-- The Etype of an expression is the nominal type of the expression,
|
-- The Etype of an expression is the nominal type of the expression,
|
||||||
-- not the actual subtype. Often these are the same, but not always.
|
-- 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
|
-- operand and result types. This is called in package Exp_Fixd to
|
||||||
-- determine whether to expand such operations.
|
-- 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);
|
procedure Wrap_Cleanup_Procedure (N : Node_Id);
|
||||||
-- Given an N_Subprogram_Body node, this procedure adds an Abort_Defer
|
-- 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
|
-- call at the start of the statement sequence, and an Abort_Undefer call
|
||||||
|
|
11
gcc/ada/fe.h
11
gcc/ada/fe.h
|
@ -6,7 +6,7 @@
|
||||||
* *
|
* *
|
||||||
* C Header File *
|
* 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 *
|
* 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- *
|
* 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_N (Fat_Pointer, Node_Id);
|
||||||
extern void Error_Msg_NE (Fat_Pointer, Node_Id, Entity_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: */
|
/* err_vars: */
|
||||||
|
|
||||||
|
@ -98,7 +98,6 @@ extern Entity_Id Error_Msg_Node_2;
|
||||||
extern Uint Error_Msg_Uint_1;
|
extern Uint Error_Msg_Uint_1;
|
||||||
extern Uint Error_Msg_Uint_2;
|
extern Uint Error_Msg_Uint_2;
|
||||||
|
|
||||||
|
|
||||||
/* exp_code: */
|
/* exp_code: */
|
||||||
|
|
||||||
#define Asm_Input_Constraint exp_code__asm_input_constraint
|
#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_Elaboration_Code_Allowed (Node_Id);
|
||||||
extern void Check_No_Implicit_Heap_Alloc (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: */
|
/* sem_eval: */
|
||||||
|
|
||||||
#define Compile_Time_Known_Value sem_eval__compile_time_known_value
|
#define Compile_Time_Known_Value sem_eval__compile_time_known_value
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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
|
-- inherited the indication from elsewhere (e.g. an address
|
||||||
-- clause, which is not good enough in RM terms!)
|
-- clause, which is not good enough in RM terms!)
|
||||||
|
|
||||||
if Present (Get_Rep_Pragma (E, Name_Atomic)) or else
|
if Present (Get_Rep_Pragma (E, Name_Atomic))
|
||||||
Present (Get_Rep_Pragma (E, Name_Atomic_Components)) or else
|
or else
|
||||||
Present (Get_Rep_Pragma (E, Name_Volatile)) or else
|
Present (Get_Rep_Pragma (E, Name_Atomic_Components))
|
||||||
Present (Get_Rep_Pragma (E, Name_Volatile_Components))
|
|
||||||
then
|
then
|
||||||
Error_Msg_N
|
Error_Msg_N
|
||||||
("stand alone atomic/volatile constant must be imported",
|
("stand alone atomic constant must be " &
|
||||||
E);
|
"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;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
@ -4173,6 +4180,20 @@ package body Freeze is
|
||||||
end if;
|
end if;
|
||||||
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
|
-- For non-foreign convention subprograms, this is where we create
|
||||||
-- the extra formals (for accessibility level and constrained bit
|
-- the extra formals (for accessibility level and constrained bit
|
||||||
-- information). We delay this till the freeze point precisely so
|
-- information). We delay this till the freeze point precisely so
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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
|
-- Ada form based literal
|
||||||
|
|
||||||
elsif C = '#' or C = ':' then
|
elsif C = '#' or else C = ':' then
|
||||||
Base := Res;
|
Base := Res;
|
||||||
Res := 0;
|
Res := 0;
|
||||||
|
|
||||||
|
|
|
@ -60,8 +60,7 @@ package body GNAT.Directory_Operations is
|
||||||
|
|
||||||
function Base_Name
|
function Base_Name
|
||||||
(Path : Path_Name;
|
(Path : Path_Name;
|
||||||
Suffix : String := "")
|
Suffix : String := "") return String
|
||||||
return String
|
|
||||||
is
|
is
|
||||||
function Get_File_Names_Case_Sensitive return Integer;
|
function Get_File_Names_Case_Sensitive return Integer;
|
||||||
pragma Import
|
pragma Import
|
||||||
|
@ -73,8 +72,7 @@ package body GNAT.Directory_Operations is
|
||||||
|
|
||||||
function Basename
|
function Basename
|
||||||
(Path : Path_Name;
|
(Path : Path_Name;
|
||||||
Suffix : String := "")
|
Suffix : String := "") return String;
|
||||||
return String;
|
|
||||||
-- This function does the job. The only difference between Basename
|
-- This function does the job. The only difference between Basename
|
||||||
-- and Base_Name (the parent function) is that the former is case
|
-- and Base_Name (the parent function) is that the former is case
|
||||||
-- sensitive, while the latter is not. Path and Suffix are adjusted
|
-- sensitive, while the latter is not. Path and Suffix are adjusted
|
||||||
|
@ -87,8 +85,7 @@ package body GNAT.Directory_Operations is
|
||||||
|
|
||||||
function Basename
|
function Basename
|
||||||
(Path : Path_Name;
|
(Path : Path_Name;
|
||||||
Suffix : String := "")
|
Suffix : String := "") return String
|
||||||
return String
|
|
||||||
is
|
is
|
||||||
Cut_Start : Natural :=
|
Cut_Start : Natural :=
|
||||||
Strings.Fixed.Index
|
Strings.Fixed.Index
|
||||||
|
@ -227,8 +224,7 @@ package body GNAT.Directory_Operations is
|
||||||
|
|
||||||
function Expand_Path
|
function Expand_Path
|
||||||
(Path : Path_Name;
|
(Path : Path_Name;
|
||||||
Mode : Environment_Style := System_Default)
|
Mode : Environment_Style := System_Default) return Path_Name
|
||||||
return Path_Name
|
|
||||||
is
|
is
|
||||||
Environment_Variable_Char : Character;
|
Environment_Variable_Char : Character;
|
||||||
pragma Import (C, Environment_Variable_Char, "__gnat_environment_char");
|
pragma Import (C, Environment_Variable_Char, "__gnat_environment_char");
|
||||||
|
@ -519,8 +515,7 @@ package body GNAT.Directory_Operations is
|
||||||
|
|
||||||
function Format_Pathname
|
function Format_Pathname
|
||||||
(Path : Path_Name;
|
(Path : Path_Name;
|
||||||
Style : Path_Style := System_Default)
|
Style : Path_Style := System_Default) return String
|
||||||
return String
|
|
||||||
is
|
is
|
||||||
N_Path : String := Path;
|
N_Path : String := Path;
|
||||||
K : Positive := N_Path'First;
|
K : Positive := N_Path'First;
|
||||||
|
@ -636,8 +631,7 @@ package body GNAT.Directory_Operations is
|
||||||
C_File_Name : constant String := Dir_Name & ASCII.NUL;
|
C_File_Name : constant String := Dir_Name & ASCII.NUL;
|
||||||
|
|
||||||
function opendir
|
function opendir
|
||||||
(File_Name : String)
|
(File_Name : String) return Dir_Type_Value;
|
||||||
return Dir_Type_Value;
|
|
||||||
pragma Import (C, opendir, "opendir");
|
pragma Import (C, opendir, "opendir");
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
@ -668,8 +662,7 @@ package body GNAT.Directory_Operations is
|
||||||
|
|
||||||
function readdir_gnat
|
function readdir_gnat
|
||||||
(Directory : System.Address;
|
(Directory : System.Address;
|
||||||
Buffer : System.Address)
|
Buffer : System.Address) return System.Address;
|
||||||
return System.Address;
|
|
||||||
pragma Import (C, readdir_gnat, "__gnat_readdir");
|
pragma Import (C, readdir_gnat, "__gnat_readdir");
|
||||||
|
|
||||||
function strlen (S : Address) return Integer;
|
function strlen (S : Address) return Integer;
|
||||||
|
|
|
@ -122,8 +122,7 @@ package GNAT.Directory_Operations is
|
||||||
|
|
||||||
function Base_Name
|
function Base_Name
|
||||||
(Path : Path_Name;
|
(Path : Path_Name;
|
||||||
Suffix : String := "")
|
Suffix : String := "") return String;
|
||||||
return String;
|
|
||||||
-- Any directory prefix is removed. If Suffix is non-empty and is a
|
-- 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
|
-- suffix of Path, it is removed. This is equivalent to the UNIX basename
|
||||||
-- command. The following rule is always true:
|
-- command. The following rule is always true:
|
||||||
|
@ -158,8 +157,7 @@ package GNAT.Directory_Operations is
|
||||||
|
|
||||||
function Format_Pathname
|
function Format_Pathname
|
||||||
(Path : Path_Name;
|
(Path : Path_Name;
|
||||||
Style : Path_Style := System_Default)
|
Style : Path_Style := System_Default) return Path_Name;
|
||||||
return Path_Name;
|
|
||||||
-- Removes all double directory separator and converts all '\' to '/' if
|
-- Removes all double directory separator and converts all '\' to '/' if
|
||||||
-- Style is UNIX and converts all '/' to '\' if Style is set to DOS. This
|
-- 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
|
-- function will help to provide a consistent naming scheme running for
|
||||||
|
@ -187,8 +185,7 @@ package GNAT.Directory_Operations is
|
||||||
|
|
||||||
function Expand_Path
|
function Expand_Path
|
||||||
(Path : Path_Name;
|
(Path : Path_Name;
|
||||||
Mode : Environment_Style := System_Default)
|
Mode : Environment_Style := System_Default) return Path_Name;
|
||||||
return Path_Name;
|
|
||||||
-- Returns Path with environment variables (or logical names on OpenVMS)
|
-- Returns Path with environment variables (or logical names on OpenVMS)
|
||||||
-- replaced by the current environment variable value. For example,
|
-- replaced by the current environment variable value. For example,
|
||||||
-- $HOME/mydir will be replaced by /home/joe/mydir if $HOME environment
|
-- $HOME/mydir will be replaced by /home/joe/mydir if $HOME environment
|
||||||
|
|
|
@ -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;
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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;
|
Main_Unit_Node : Node_Id;
|
||||||
-- Compilation unit node for main unit
|
-- Compilation unit node for main unit
|
||||||
|
|
||||||
Main_Unit_Entity : Node_Id;
|
|
||||||
-- Compilation unit entity for main unit
|
|
||||||
|
|
||||||
Main_Kind : Node_Kind;
|
Main_Kind : Node_Kind;
|
||||||
-- Kind of main compilation unit node.
|
-- Kind of main compilation unit node.
|
||||||
|
|
||||||
|
@ -193,7 +190,7 @@ begin
|
||||||
Write_Eol;
|
Write_Eol;
|
||||||
Write_Str ("GNAT ");
|
Write_Str ("GNAT ");
|
||||||
Write_Str (Gnat_Version_String);
|
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;
|
Write_Eol;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
@ -277,7 +274,6 @@ begin
|
||||||
Original_Operating_Mode := Operating_Mode;
|
Original_Operating_Mode := Operating_Mode;
|
||||||
Frontend;
|
Frontend;
|
||||||
Main_Unit_Node := Cunit (Main_Unit);
|
Main_Unit_Node := Cunit (Main_Unit);
|
||||||
Main_Unit_Entity := Cunit_Entity (Main_Unit);
|
|
||||||
Main_Kind := Nkind (Unit (Main_Unit_Node));
|
Main_Kind := Nkind (Unit (Main_Unit_Node));
|
||||||
|
|
||||||
-- Check for suspicious or incorrect body present if we are doing
|
-- Check for suspicious or incorrect body present if we are doing
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -379,7 +379,7 @@ begin
|
||||||
Write_Eol;
|
Write_Eol;
|
||||||
Write_Str ("GNATBIND ");
|
Write_Str ("GNATBIND ");
|
||||||
Write_Str (Gnat_Version_String);
|
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;
|
Write_Eol;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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
|
if not Is_Duplicated (SNum) then
|
||||||
declare
|
declare
|
||||||
Info : Unit_Info := Unit.Table (Sorted_Units.Table (SNum));
|
Info : constant Unit_Info :=
|
||||||
|
Unit.Table (Sorted_Units.Table (SNum));
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if Is_Writable_File (Info.File_Name.all) then
|
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
|
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_Name : Temp_File_Name;
|
||||||
Offset_FD : File_Descriptor;
|
Offset_FD : File_Descriptor;
|
||||||
Save_Stdout : File_Descriptor := dup (Standout);
|
|
||||||
Buffer : String_Access;
|
Buffer : String_Access;
|
||||||
Success : Boolean;
|
Success : Boolean;
|
||||||
Failure : exception;
|
Failure : exception;
|
||||||
|
@ -690,9 +691,9 @@ procedure Gnatchop is
|
||||||
(Chop_File : File_Num;
|
(Chop_File : File_Num;
|
||||||
Source : access String)
|
Source : access String)
|
||||||
is
|
is
|
||||||
First_Unit : Unit_Num := Unit.Last + 1;
|
First_Unit : constant Unit_Num := Unit.Last + 1;
|
||||||
Bufferg : String_Access := null;
|
Bufferg : String_Access := null;
|
||||||
Parse_Ptr : File_Offset := Source'First;
|
Parse_Ptr : File_Offset := Source'First;
|
||||||
Token_Ptr : File_Offset;
|
Token_Ptr : File_Offset;
|
||||||
Info : Unit_Info;
|
Info : Unit_Info;
|
||||||
|
|
||||||
|
@ -1147,7 +1148,7 @@ procedure Gnatchop is
|
||||||
Put (Standard_Error, Gnatvsn.Gnat_Version_String);
|
Put (Standard_Error, Gnatvsn.Gnat_Version_String);
|
||||||
Put_Line
|
Put_Line
|
||||||
(Standard_Error,
|
(Standard_Error,
|
||||||
" Copyright 1998-2000, Ada Core Technologies Inc.");
|
" Copyright 1998-2004, Ada Core Technologies Inc.");
|
||||||
|
|
||||||
when 'w' =>
|
when 'w' =>
|
||||||
Overwrite_Files := True;
|
Overwrite_Files := True;
|
||||||
|
@ -1736,7 +1737,7 @@ begin
|
||||||
|
|
||||||
if Warning_Count > 0 then
|
if Warning_Count > 0 then
|
||||||
declare
|
declare
|
||||||
Warnings_Msg : String := Warning_Count'Img & " warning(s)";
|
Warnings_Msg : constant String := Warning_Count'Img & " warning(s)";
|
||||||
begin
|
begin
|
||||||
Error_Msg (Warnings_Msg (2 .. Warnings_Msg'Last), Warning => True);
|
Error_Msg (Warnings_Msg (2 .. Warnings_Msg'Last), Warning => True);
|
||||||
end;
|
end;
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -24,10 +24,10 @@
|
||||||
-- --
|
-- --
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
|
|
||||||
with Xr_Tabls; use Xr_Tabls;
|
with Xr_Tabls; use Xr_Tabls;
|
||||||
with Xref_Lib; use Xref_Lib;
|
with Xref_Lib; use Xref_Lib;
|
||||||
with Osint; use Osint;
|
with Osint; use Osint;
|
||||||
with Types; use Types;
|
with Types; use Types;
|
||||||
|
|
||||||
with Gnatvsn;
|
with Gnatvsn;
|
||||||
with Opt;
|
with Opt;
|
||||||
|
@ -41,7 +41,6 @@ with GNAT.Strings; use GNAT.Strings;
|
||||||
---------------
|
---------------
|
||||||
|
|
||||||
procedure Gnatfind is
|
procedure Gnatfind is
|
||||||
|
|
||||||
Output_Ref : Boolean := False;
|
Output_Ref : Boolean := False;
|
||||||
Pattern : Xref_Lib.Search_Pattern;
|
Pattern : Xref_Lib.Search_Pattern;
|
||||||
Local_Symbols : Boolean := True;
|
Local_Symbols : Boolean := True;
|
||||||
|
@ -240,7 +239,7 @@ procedure Gnatfind is
|
||||||
procedure Write_Usage is
|
procedure Write_Usage is
|
||||||
begin
|
begin
|
||||||
Put_Line ("GNATFIND " & Gnatvsn.Gnat_Version_String
|
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]]] "
|
Put_Line ("Usage: gnatfind pattern[:sourcefile[:line[:column]]] "
|
||||||
& "[file1 file2 ...]");
|
& "[file1 file2 ...]");
|
||||||
New_Line;
|
New_Line;
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -77,10 +77,9 @@ begin
|
||||||
exit when Next_Arg > Argument_Count;
|
exit when Next_Arg > Argument_Count;
|
||||||
|
|
||||||
Process_One_Arg : declare
|
Process_One_Arg : declare
|
||||||
Arg : String := Argument (Next_Arg);
|
Arg : constant String := Argument (Next_Arg);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
|
||||||
if Arg'Length > 9 and then Arg (1 .. 9) = "--create=" then
|
if Arg'Length > 9 and then Arg (1 .. 9) = "--create=" then
|
||||||
if Mode = None then
|
if Mode = None then
|
||||||
Mode := Create;
|
Mode := Create;
|
||||||
|
@ -192,28 +191,29 @@ begin
|
||||||
--
|
--
|
||||||
Include_Dirs := 0;
|
Include_Dirs := 0;
|
||||||
Include_Dir_Name := new String'(Include_Dir_Default_Prefix);
|
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
|
loop
|
||||||
declare
|
declare
|
||||||
Dir : String_Access := String_Access
|
Dir : constant String_Access := String_Access
|
||||||
(Get_Next_Dir_In_Path (String_Access (Include_Dir_Name)));
|
(Get_Next_Dir_In_Path (Include_Dir_Name));
|
||||||
begin
|
begin
|
||||||
exit when Dir = null;
|
exit when Dir = null;
|
||||||
Include_Dirs := Include_Dirs + 1;
|
Include_Dirs := Include_Dirs + 1;
|
||||||
Include_Dir (Include_Dirs)
|
Include_Dir (Include_Dirs) :=
|
||||||
:= String_Access (Normalize_Directory_Name (Dir.all));
|
String_Access (Normalize_Directory_Name (Dir.all));
|
||||||
end;
|
end;
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
Object_Dirs := 0;
|
Object_Dirs := 0;
|
||||||
Object_Dir_Name := new String'(Object_Dir_Default_Prefix);
|
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
|
loop
|
||||||
declare
|
declare
|
||||||
Dir : String_Access := String_Access
|
Dir : constant String_Access :=
|
||||||
(Get_Next_Dir_In_Path (String_Access (Object_Dir_Name)));
|
String_Access
|
||||||
|
(Get_Next_Dir_In_Path (Object_Dir_Name));
|
||||||
begin
|
begin
|
||||||
exit when Dir = null;
|
exit when Dir = null;
|
||||||
Object_Dirs := Object_Dirs + 1;
|
Object_Dirs := Object_Dirs + 1;
|
||||||
|
@ -225,7 +225,6 @@ begin
|
||||||
-- "Make" an alternate sublibrary for each default sublibrary.
|
-- "Make" an alternate sublibrary for each default sublibrary.
|
||||||
|
|
||||||
for Dirs in 1 .. Object_Dirs loop
|
for Dirs in 1 .. Object_Dirs loop
|
||||||
|
|
||||||
Make_Args (1) :=
|
Make_Args (1) :=
|
||||||
new String'("-C");
|
new String'("-C");
|
||||||
|
|
||||||
|
@ -269,13 +268,14 @@ begin
|
||||||
Make_Path := Locate_Exec_On_Path (Make);
|
Make_Path := Locate_Exec_On_Path (Make);
|
||||||
Put (Make);
|
Put (Make);
|
||||||
|
|
||||||
for I in 1 .. Make_Args'Last loop
|
for J in 1 .. Make_Args'Last loop
|
||||||
Put (" ");
|
Put (" ");
|
||||||
Put (Make_Args (I).all);
|
Put (Make_Args (J).all);
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
New_Line;
|
New_Line;
|
||||||
Spawn (Make_Path.all, Make_Args, Success);
|
Spawn (Make_Path.all, Make_Args, Success);
|
||||||
|
|
||||||
if not Success then
|
if not Success then
|
||||||
Put_Line (Standard_Error, "Error: Make failed");
|
Put_Line (Standard_Error, "Error: Make failed");
|
||||||
Exit_Program (E_Fatal);
|
Exit_Program (E_Fatal);
|
||||||
|
@ -285,7 +285,7 @@ begin
|
||||||
|
|
||||||
when Set =>
|
when Set =>
|
||||||
|
|
||||||
-- Validate arguments.
|
-- Validate arguments
|
||||||
|
|
||||||
if Lib_Dir = null then
|
if Lib_Dir = null then
|
||||||
Put_Line (Standard_Error,
|
Put_Line (Standard_Error,
|
||||||
|
@ -311,7 +311,7 @@ begin
|
||||||
Exit_Program (E_Fatal);
|
Exit_Program (E_Fatal);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- Give instructions.
|
-- Give instructions
|
||||||
|
|
||||||
Put_Line ("Copy the contents of "
|
Put_Line ("Copy the contents of "
|
||||||
& ADC_File.all & " into your GNAT.ADC file");
|
& ADC_File.all & " into your GNAT.ADC file");
|
||||||
|
@ -332,7 +332,7 @@ begin
|
||||||
|
|
||||||
when Delete =>
|
when Delete =>
|
||||||
|
|
||||||
-- Give instructions.
|
-- Give instructions
|
||||||
|
|
||||||
Put_Line ("GNAT Librarian DELETE not yet implemented.");
|
Put_Line ("GNAT Librarian DELETE not yet implemented.");
|
||||||
Put_Line ("Use appropriate system tools to remove library");
|
Put_Line ("Use appropriate system tools to remove library");
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -26,7 +26,6 @@
|
||||||
|
|
||||||
-- Gnatlink usage: please consult the gnat documentation
|
-- Gnatlink usage: please consult the gnat documentation
|
||||||
|
|
||||||
with Ada.Exceptions; use Ada.Exceptions;
|
|
||||||
with ALI; use ALI;
|
with ALI; use ALI;
|
||||||
with Gnatvsn; use Gnatvsn;
|
with Gnatvsn; use Gnatvsn;
|
||||||
with Hostparm;
|
with Hostparm;
|
||||||
|
@ -40,6 +39,7 @@ with Table;
|
||||||
with Types;
|
with Types;
|
||||||
|
|
||||||
with Ada.Command_Line; use Ada.Command_Line;
|
with Ada.Command_Line; use Ada.Command_Line;
|
||||||
|
with Ada.Exceptions; use Ada.Exceptions;
|
||||||
with GNAT.OS_Lib; use GNAT.OS_Lib;
|
with GNAT.OS_Lib; use GNAT.OS_Lib;
|
||||||
with Interfaces.C_Streams; use Interfaces.C_Streams;
|
with Interfaces.C_Streams; use Interfaces.C_Streams;
|
||||||
with System.CRTL;
|
with System.CRTL;
|
||||||
|
@ -234,9 +234,10 @@ procedure Gnatlink is
|
||||||
|
|
||||||
procedure Delete (Name : in String) is
|
procedure Delete (Name : in String) is
|
||||||
Status : int;
|
Status : int;
|
||||||
|
pragma Unreferenced (Status);
|
||||||
begin
|
begin
|
||||||
Status := unlink (Name'Address);
|
Status := unlink (Name'Address);
|
||||||
|
-- Is it really right to ignore an error here ???
|
||||||
end Delete;
|
end Delete;
|
||||||
|
|
||||||
---------------
|
---------------
|
||||||
|
@ -602,6 +603,9 @@ procedure Gnatlink is
|
||||||
Nfirst : Integer;
|
Nfirst : Integer;
|
||||||
-- Current line slice (the slice does not contain line terminator)
|
-- 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;
|
Objs_Begin : Integer := 0;
|
||||||
-- First object file index in Linker_Objects table
|
-- First object file index in Linker_Objects table
|
||||||
|
|
||||||
|
@ -986,20 +990,45 @@ procedure Gnatlink is
|
||||||
elsif Next_Line (Nfirst .. Nlast) = "-ldecgnat"
|
elsif Next_Line (Nfirst .. Nlast) = "-ldecgnat"
|
||||||
or else Next_Line (Nfirst .. Nlast) = "-lgnarl"
|
or else Next_Line (Nfirst .. Nlast) = "-lgnarl"
|
||||||
or else Next_Line (Nfirst .. Nlast) = "-lgnat"
|
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
|
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
|
-- Given a Gnat standard library, search the
|
||||||
-- library path to find the library location
|
-- library path to find the library location
|
||||||
|
|
||||||
declare
|
declare
|
||||||
File_Path : String_Access;
|
File_Path : String_Access;
|
||||||
|
|
||||||
Object_Lib_Extension : constant String :=
|
Object_Lib_Extension : constant String :=
|
||||||
Value (Object_Library_Ext_Ptr);
|
Value (Object_Library_Ext_Ptr);
|
||||||
|
|
||||||
File_Name : constant String := "lib" &
|
File_Name : constant String := "lib" &
|
||||||
Next_Line (Nfirst + 2 .. Nlast) &
|
Next_Line (Nfirst + 2 .. Last) &
|
||||||
Object_Lib_Extension;
|
Object_Lib_Extension;
|
||||||
|
|
||||||
Run_Path_Opt : constant String :=
|
Run_Path_Opt : constant String :=
|
||||||
Value (Run_Path_Option_Ptr);
|
Value (Run_Path_Option_Ptr);
|
||||||
GCC_Index : Natural;
|
|
||||||
|
GCC_Index : Natural;
|
||||||
Run_Path_Opt_Index : Natural := 0;
|
Run_Path_Opt_Index : Natural := 0;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
@ -1189,7 +1218,7 @@ procedure Gnatlink is
|
||||||
Write_Eol;
|
Write_Eol;
|
||||||
Write_Str ("GNATLINK ");
|
Write_Str ("GNATLINK ");
|
||||||
Write_Str (Gnat_Version_String);
|
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;
|
Write_Eol;
|
||||||
end if;
|
end if;
|
||||||
end Write_Header;
|
end Write_Header;
|
||||||
|
@ -1586,7 +1615,7 @@ begin
|
||||||
-- Remove duplicate IDENTIFICATION directives (VMS)
|
-- Remove duplicate IDENTIFICATION directives (VMS)
|
||||||
|
|
||||||
if Linker_Options.Table (J)'Length > 27
|
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="
|
= "--for-linker=IDENTIFICATION="
|
||||||
then
|
then
|
||||||
if IDENT_Op then
|
if IDENT_Op then
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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;
|
Main_File : File_Name_Type;
|
||||||
Ali_File : File_Name_Type;
|
Ali_File : File_Name_Type;
|
||||||
|
Text : Text_Buffer_Ptr;
|
||||||
Text : Text_Buffer_Ptr;
|
Next_Arg : Positive;
|
||||||
Id : ALI_Id;
|
|
||||||
|
|
||||||
Next_Arg : Positive;
|
|
||||||
|
|
||||||
Too_Long : Boolean := False;
|
Too_Long : Boolean := False;
|
||||||
-- When True, lines are too long for multi-column output and each
|
-- When True, lines are too long for multi-column output and each
|
||||||
|
@ -219,9 +216,8 @@ procedure Gnatls is
|
||||||
------------------------------
|
------------------------------
|
||||||
|
|
||||||
function Corresponding_Sdep_Entry
|
function Corresponding_Sdep_Entry
|
||||||
(A : ALI_Id;
|
(A : ALI_Id;
|
||||||
U : Unit_Id)
|
U : Unit_Id) return Sdep_Id
|
||||||
return Sdep_Id
|
|
||||||
is
|
is
|
||||||
begin
|
begin
|
||||||
for D in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop
|
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
|
-- Compute maximum of each column
|
||||||
|
|
||||||
for Id in ALIs.First .. ALIs.Last loop
|
for Id in ALIs.First .. ALIs.Last loop
|
||||||
|
|
||||||
Get_Name_String (Units.Table (ALIs.Table (Id).First_Unit).Uname);
|
Get_Name_String (Units.Table (ALIs.Table (Id).First_Unit).Uname);
|
||||||
if Also_Predef or else not Is_Internal_Unit then
|
if Also_Predef or else not Is_Internal_Unit then
|
||||||
|
|
||||||
|
@ -829,7 +824,6 @@ begin
|
||||||
Scan_Args : while Next_Arg < Arg_Count loop
|
Scan_Args : while Next_Arg < Arg_Count loop
|
||||||
declare
|
declare
|
||||||
Next_Argv : String (1 .. Len_Arg (Next_Arg));
|
Next_Argv : String (1 .. Len_Arg (Next_Arg));
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Fill_Arg (Next_Argv'Address, Next_Arg);
|
Fill_Arg (Next_Argv'Address, Next_Arg);
|
||||||
Scan_Ls_Arg (Next_Argv, And_Save => True);
|
Scan_Ls_Arg (Next_Argv, And_Save => True);
|
||||||
|
@ -866,7 +860,7 @@ begin
|
||||||
Write_Eol;
|
Write_Eol;
|
||||||
Write_Str ("GNATLS ");
|
Write_Str ("GNATLS ");
|
||||||
Write_Str (Gnat_Version_String);
|
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_Eol;
|
Write_Eol;
|
||||||
Write_Str ("Source Search Path:");
|
Write_Str ("Source Search Path:");
|
||||||
|
@ -942,9 +936,16 @@ begin
|
||||||
|
|
||||||
if Get_Name_Table_Info (Ali_File) = 0 then
|
if Get_Name_Table_Info (Ali_File) = 0 then
|
||||||
Text := Read_Library_Info (Ali_File, True);
|
Text := Read_Library_Info (Ali_File, True);
|
||||||
Id :=
|
|
||||||
Scan_ALI
|
declare
|
||||||
(Ali_File, Text, Ignore_ED => False, Err => False);
|
Discard : ALI_Id;
|
||||||
|
pragma Unreferenced (Discard);
|
||||||
|
begin
|
||||||
|
Discard :=
|
||||||
|
Scan_ALI
|
||||||
|
(Ali_File, Text, Ignore_ED => False, Err => False);
|
||||||
|
end;
|
||||||
|
|
||||||
Free (Text);
|
Free (Text);
|
||||||
end if;
|
end if;
|
||||||
end if;
|
end if;
|
||||||
|
@ -1029,9 +1030,8 @@ begin
|
||||||
end;
|
end;
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
-- All done. Set proper exit status.
|
-- All done. Set proper exit status
|
||||||
|
|
||||||
Namet.Finalize;
|
Namet.Finalize;
|
||||||
Exit_Program (E_Success);
|
Exit_Program (E_Success);
|
||||||
|
|
||||||
end Gnatls;
|
end Gnatls;
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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
|
-- execution generating memory allocation where data is collected (such as
|
||||||
-- number of allocations, amount of memory allocated, high water mark, etc.)
|
-- 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.Text_IO; use Ada.Text_IO;
|
||||||
with Ada.Float_Text_IO;
|
with Ada.Float_Text_IO;
|
||||||
with Ada.Integer_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.Heap_Sort_G;
|
||||||
with GNAT.OS_Lib; use GNAT.OS_Lib;
|
with GNAT.OS_Lib; use GNAT.OS_Lib;
|
||||||
with GNAT.HTable; use GNAT.HTable;
|
with GNAT.HTable; use GNAT.HTable;
|
||||||
|
|
||||||
with System; use System;
|
with System; use System;
|
||||||
with System.Storage_Elements; use System.Storage_Elements;
|
with System.Storage_Elements; use System.Storage_Elements;
|
||||||
|
|
||||||
|
@ -230,7 +234,7 @@ procedure Gnatmem is
|
||||||
New_Line;
|
New_Line;
|
||||||
Put ("GNATMEM ");
|
Put ("GNATMEM ");
|
||||||
Put (Gnat_Version_String);
|
Put (Gnat_Version_String);
|
||||||
Put_Line (" Copyright 1997-2003 Free Software Foundation, Inc.");
|
Put_Line (" Copyright 1997-2004 Free Software Foundation, Inc.");
|
||||||
New_Line;
|
New_Line;
|
||||||
|
|
||||||
Put_Line ("Usage: gnatmem switches [depth] exename");
|
Put_Line ("Usage: gnatmem switches [depth] exename");
|
||||||
|
@ -287,20 +291,20 @@ procedure Gnatmem is
|
||||||
|
|
||||||
when 's' =>
|
when 's' =>
|
||||||
declare
|
declare
|
||||||
S : String (Sort_Order'Range) := Parameter;
|
S : constant String (Sort_Order'Range) := Parameter;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
for J in Sort_Order'Range loop
|
for J in Sort_Order'Range loop
|
||||||
if S (J) = 'n' or else S (J) = 'w'
|
if S (J) = 'n' or else
|
||||||
or else S (J) = 'h' then
|
S (J) = 'w' or else
|
||||||
|
S (J) = 'h'
|
||||||
|
then
|
||||||
Sort_Order (J) := S (J);
|
Sort_Order (J) := S (J);
|
||||||
else
|
else
|
||||||
raise Constraint_Error;
|
Put_Line ("Invalid sort criteria string.");
|
||||||
|
GNAT.OS_Lib.OS_Exit (1);
|
||||||
end if;
|
end if;
|
||||||
end loop;
|
end loop;
|
||||||
exception
|
|
||||||
when Constraint_Error =>
|
|
||||||
Put_Line ("Invalid sort criteria string.");
|
|
||||||
GNAT.OS_Lib.OS_Exit (1);
|
|
||||||
end;
|
end;
|
||||||
|
|
||||||
when others =>
|
when others =>
|
||||||
|
@ -607,6 +611,8 @@ begin
|
||||||
|
|
||||||
Result : Integer;
|
Result : Integer;
|
||||||
|
|
||||||
|
-- Start of processing for Lt
|
||||||
|
|
||||||
begin
|
begin
|
||||||
for S in Sort_Order'Range loop
|
for S in Sort_Order'Range loop
|
||||||
Result := Apply_Sort_Criterion (Sort_Order (S));
|
Result := Apply_Sort_Criterion (Sort_Order (S));
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -66,7 +66,7 @@ procedure Gnatname is
|
||||||
Table_Initial => 10,
|
Table_Initial => 10,
|
||||||
Table_Increment => 10,
|
Table_Increment => 10,
|
||||||
Table_Name => "Gnatname.Excluded_Patterns");
|
Table_Name => "Gnatname.Excluded_Patterns");
|
||||||
-- Table to accumulate the negative patterns.
|
-- Table to accumulate the negative patterns
|
||||||
|
|
||||||
package Foreign_Patterns is new Table.Table
|
package Foreign_Patterns is new Table.Table
|
||||||
(Table_Component_Type => String_Access,
|
(Table_Component_Type => String_Access,
|
||||||
|
@ -75,7 +75,7 @@ procedure Gnatname is
|
||||||
Table_Initial => 10,
|
Table_Initial => 10,
|
||||||
Table_Increment => 10,
|
Table_Increment => 10,
|
||||||
Table_Name => "Gnatname.Foreign_Patterns");
|
Table_Name => "Gnatname.Foreign_Patterns");
|
||||||
-- Table to accumulate the foreign patterns.
|
-- Table to accumulate the foreign patterns
|
||||||
|
|
||||||
package Patterns is new Table.Table
|
package Patterns is new Table.Table
|
||||||
(Table_Component_Type => String_Access,
|
(Table_Component_Type => String_Access,
|
||||||
|
@ -84,7 +84,7 @@ procedure Gnatname is
|
||||||
Table_Initial => 10,
|
Table_Initial => 10,
|
||||||
Table_Increment => 10,
|
Table_Increment => 10,
|
||||||
Table_Name => "Gnatname.Patterns");
|
Table_Name => "Gnatname.Patterns");
|
||||||
-- Table to accumulate the name patterns.
|
-- Table to accumulate the name patterns
|
||||||
|
|
||||||
package Source_Directories is new Table.Table
|
package Source_Directories is new Table.Table
|
||||||
(Table_Component_Type => String_Access,
|
(Table_Component_Type => String_Access,
|
||||||
|
@ -170,7 +170,7 @@ procedure Gnatname is
|
||||||
Output.Write_Str ("GNATNAME ");
|
Output.Write_Str ("GNATNAME ");
|
||||||
Output.Write_Str (Gnatvsn.Gnat_Version_String);
|
Output.Write_Str (Gnatvsn.Gnat_Version_String);
|
||||||
Output.Write_Line
|
Output.Write_Line
|
||||||
(" Copyright 2001-2003 Free Software Foundation, Inc.");
|
(" Copyright 2001-2004 Free Software Foundation, Inc.");
|
||||||
end if;
|
end if;
|
||||||
end Output_Version;
|
end Output_Version;
|
||||||
|
|
||||||
|
@ -261,7 +261,6 @@ procedure Gnatname is
|
||||||
exception
|
exception
|
||||||
when Invalid_Switch =>
|
when Invalid_Switch =>
|
||||||
Fail ("invalid switch " & Full_Switch);
|
Fail ("invalid switch " & Full_Switch);
|
||||||
|
|
||||||
end Scan_Args;
|
end Scan_Args;
|
||||||
|
|
||||||
-----------
|
-----------
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -55,7 +55,7 @@ with Table;
|
||||||
procedure Gnatsym is
|
procedure Gnatsym is
|
||||||
|
|
||||||
Empty_String : aliased String := "";
|
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
|
-- To initialize variables Reference and Version_String
|
||||||
|
|
||||||
Copyright_Displayed : Boolean := False;
|
Copyright_Displayed : Boolean := False;
|
||||||
|
@ -111,7 +111,7 @@ procedure Gnatsym is
|
||||||
Write_Eol;
|
Write_Eol;
|
||||||
Write_Str ("GNATSYMB ");
|
Write_Str ("GNATSYMB ");
|
||||||
Write_Str (Gnat_Version_String);
|
Write_Str (Gnat_Version_String);
|
||||||
Write_Str (" Copyright 2003 Free Software Foundation, Inc");
|
Write_Str (" Copyright 2003-2004 Free Software Foundation, Inc");
|
||||||
Write_Eol;
|
Write_Eol;
|
||||||
Copyright_Displayed := True;
|
Copyright_Displayed := True;
|
||||||
end if;
|
end if;
|
||||||
|
@ -224,8 +224,7 @@ begin
|
||||||
Write_Line ("""");
|
Write_Line ("""");
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- Initialize the symbol file and, if specified, read the reference
|
-- Initialize symbol file and, if specified, read reference file
|
||||||
-- file.
|
|
||||||
|
|
||||||
Symbols.Initialize
|
Symbols.Initialize
|
||||||
(Symbol_File => Symbol_File_Name.all,
|
(Symbol_File => Symbol_File_Name.all,
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -72,7 +72,7 @@ procedure Gnatxref is
|
||||||
when ASCII.NUL =>
|
when ASCII.NUL =>
|
||||||
exit;
|
exit;
|
||||||
|
|
||||||
when 'a' =>
|
when 'a' =>
|
||||||
if GNAT.Command_Line.Full_Switch = "a" then
|
if GNAT.Command_Line.Full_Switch = "a" then
|
||||||
Read_Only := True;
|
Read_Only := True;
|
||||||
|
|
||||||
|
@ -83,49 +83,49 @@ procedure Gnatxref is
|
||||||
Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter);
|
Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
when 'd' =>
|
when 'd' =>
|
||||||
Der_Info := True;
|
Der_Info := True;
|
||||||
|
|
||||||
when 'f' =>
|
when 'f' =>
|
||||||
Full_Path_Name := True;
|
Full_Path_Name := True;
|
||||||
|
|
||||||
when 'g' =>
|
when 'g' =>
|
||||||
Local_Symbols := False;
|
Local_Symbols := False;
|
||||||
|
|
||||||
when 'h' =>
|
when 'h' =>
|
||||||
Write_Usage;
|
Write_Usage;
|
||||||
|
|
||||||
when 'I' =>
|
when 'I' =>
|
||||||
Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter);
|
Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter);
|
||||||
Osint.Add_Lib_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
|
if GNAT.Command_Line.Full_Switch = "nostdinc" then
|
||||||
Opt.No_Stdinc := True;
|
Opt.No_Stdinc := True;
|
||||||
elsif GNAT.Command_Line.Full_Switch = "nostlib" then
|
elsif GNAT.Command_Line.Full_Switch = "nostlib" then
|
||||||
Opt.No_Stdlib := True;
|
Opt.No_Stdlib := True;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
when 'p' =>
|
when 'p' =>
|
||||||
declare
|
declare
|
||||||
S : constant String := GNAT.Command_Line.Parameter;
|
S : constant String := GNAT.Command_Line.Parameter;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Prj_File_Length := S'Length;
|
Prj_File_Length := S'Length;
|
||||||
Prj_File (1 .. Prj_File_Length) := S;
|
Prj_File (1 .. Prj_File_Length) := S;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
when 'u' =>
|
when 'u' =>
|
||||||
Search_Unused := True;
|
Search_Unused := True;
|
||||||
Vi_Mode := False;
|
Vi_Mode := False;
|
||||||
|
|
||||||
when 'v' =>
|
when 'v' =>
|
||||||
Vi_Mode := True;
|
Vi_Mode := True;
|
||||||
Search_Unused := False;
|
Search_Unused := False;
|
||||||
|
|
||||||
-- The only switch starting with -- recognized is --RTS
|
-- The only switch starting with -- recognized is --RTS
|
||||||
|
|
||||||
when '-' =>
|
when '-' =>
|
||||||
|
|
||||||
-- Check that it is the first time we see this switch
|
-- Check that it is the first time we see this switch
|
||||||
|
|
||||||
if RTS_Specified = null then
|
if RTS_Specified = null then
|
||||||
|
@ -210,7 +210,7 @@ procedure Gnatxref is
|
||||||
procedure Write_Usage is
|
procedure Write_Usage is
|
||||||
begin
|
begin
|
||||||
Put_Line ("GNATXREF " & Gnatvsn.Gnat_Version_String
|
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 ...");
|
Put_Line ("Usage: gnatxref [switches] file1 file2 ...");
|
||||||
New_Line;
|
New_Line;
|
||||||
Put_Line (" file ... list of source files to xref, " &
|
Put_Line (" file ... list of source files to xref, " &
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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 Extend (Dir : String) is
|
||||||
|
|
||||||
procedure Recursive_Extend (D : String);
|
procedure Recursive_Extend (D : String);
|
||||||
-- Recursively display all subdirectories of D.
|
-- Recursively display all subdirectories of D
|
||||||
|
|
||||||
----------------------
|
----------------------
|
||||||
-- Recursive_Extend --
|
-- Recursive_Extend --
|
||||||
|
@ -355,7 +355,7 @@ begin
|
||||||
Put (Standard_Error, "GPRCMD ");
|
Put (Standard_Error, "GPRCMD ");
|
||||||
Put (Standard_Error, Gnatvsn.Gnat_Version_String);
|
Put (Standard_Error, Gnatvsn.Gnat_Version_String);
|
||||||
Put_Line (Standard_Error,
|
Put_Line (Standard_Error,
|
||||||
" Copyright 2002-2003, Free Software Fundation, Inc.");
|
" Copyright 2002-2004, Free Software Fundation, Inc.");
|
||||||
Usage;
|
Usage;
|
||||||
|
|
||||||
elsif Cmd = "pwd" then
|
elsif Cmd = "pwd" then
|
||||||
|
@ -437,8 +437,8 @@ begin
|
||||||
Find_Program_Name;
|
Find_Program_Name;
|
||||||
|
|
||||||
declare
|
declare
|
||||||
Path : String_Access :=
|
Path : constant String_Access :=
|
||||||
Locate_Exec_On_Path (Name_Buffer (1 .. Name_Len));
|
Locate_Exec_On_Path (Name_Buffer (1 .. Name_Len));
|
||||||
Index : Natural;
|
Index : Natural;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
@ -454,7 +454,7 @@ begin
|
||||||
and then Path (Index - 3 .. Index - 1) = "bin"
|
and then Path (Index - 3 .. Index - 1) = "bin"
|
||||||
and then Path (Index - 4) = Directory_Separator
|
and then Path (Index - 4) = Directory_Separator
|
||||||
then
|
then
|
||||||
-- We have found the <prefix>, return it.
|
-- We have found the <prefix>, return it
|
||||||
|
|
||||||
Put (Path (Path'First .. Index - 5));
|
Put (Path (Path'First .. Index - 5));
|
||||||
end if;
|
end if;
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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 Csets;
|
||||||
with Err_Vars; use Err_Vars;
|
with Err_Vars; use Err_Vars;
|
||||||
with Errutil;
|
with Errutil;
|
||||||
|
@ -41,8 +39,9 @@ with Snames;
|
||||||
with Stringt; use Stringt;
|
with Stringt; use Stringt;
|
||||||
with Types; use Types;
|
with Types; use Types;
|
||||||
|
|
||||||
|
with Ada.Text_IO; use Ada.Text_IO;
|
||||||
with GNAT.Command_Line;
|
with GNAT.Command_Line;
|
||||||
with GNAT.OS_Lib; use GNAT.OS_Lib;
|
with GNAT.OS_Lib; use GNAT.OS_Lib;
|
||||||
|
|
||||||
package body GPrep is
|
package body GPrep is
|
||||||
|
|
||||||
|
@ -57,11 +56,11 @@ package body GPrep is
|
||||||
Outfile_Name : String_Access;
|
Outfile_Name : String_Access;
|
||||||
Deffile_Name : String_Access;
|
Deffile_Name : String_Access;
|
||||||
|
|
||||||
Source_Ref_Pragma : Boolean := False; -- Set if -r switch set
|
Source_Ref_Pragma : Boolean := False;
|
||||||
-- Record command line options
|
-- Record command line options (set if -r switch set)
|
||||||
|
|
||||||
Text_Outfile : aliased Ada.Text_IO.File_Type;
|
Text_Outfile : aliased Ada.Text_IO.File_Type;
|
||||||
Outfile : File_Access := Text_Outfile'Access;
|
Outfile : constant File_Access := Text_Outfile'Access;
|
||||||
|
|
||||||
-----------------
|
-----------------
|
||||||
-- Subprograms --
|
-- Subprograms --
|
||||||
|
@ -87,11 +86,11 @@ package body GPrep is
|
||||||
|
|
||||||
procedure Put_Char_To_Outfile (C : Character);
|
procedure Put_Char_To_Outfile (C : Character);
|
||||||
-- Output one character to the output file.
|
-- Output one character to the output file.
|
||||||
-- Used to initialize the preprocessor..
|
-- Used to initialize the preprocessor.
|
||||||
|
|
||||||
procedure New_EOL_To_Outfile;
|
procedure New_EOL_To_Outfile;
|
||||||
-- Output a new line to the output file.
|
-- Output a new line to the output file.
|
||||||
-- used to initialize the preprocessor.
|
-- Used to initialize the preprocessor.
|
||||||
|
|
||||||
procedure Scan_Command_Line;
|
procedure Scan_Command_Line;
|
||||||
-- Scan the switches and the file names
|
-- Scan the switches and the file names
|
||||||
|
@ -108,7 +107,7 @@ package body GPrep is
|
||||||
if not Copyright_Displayed then
|
if not Copyright_Displayed then
|
||||||
Write_Line ("GNAT Preprocessor " &
|
Write_Line ("GNAT Preprocessor " &
|
||||||
Gnatvsn.Gnat_Version_String &
|
Gnatvsn.Gnat_Version_String &
|
||||||
" Copyright 1996-2003 Free Software Foundation, Inc.");
|
" Copyright 1996-2004 Free Software Foundation, Inc.");
|
||||||
Copyright_Displayed := True;
|
Copyright_Displayed := True;
|
||||||
end if;
|
end if;
|
||||||
end Display_Copyright;
|
end Display_Copyright;
|
||||||
|
|
|
@ -41,6 +41,31 @@ package body Interfaces.C_Streams is
|
||||||
|
|
||||||
use type System.CRTL.size_t;
|
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 --
|
-- fread --
|
||||||
------------
|
------------
|
||||||
|
@ -49,17 +74,8 @@ package body Interfaces.C_Streams is
|
||||||
(buffer : voids;
|
(buffer : voids;
|
||||||
size : size_t;
|
size : size_t;
|
||||||
count : size_t;
|
count : size_t;
|
||||||
stream : FILEs)
|
stream : FILEs) return size_t
|
||||||
return size_t
|
|
||||||
is
|
is
|
||||||
function C_fread
|
|
||||||
(buffer : voids;
|
|
||||||
size : size_t;
|
|
||||||
count : size_t;
|
|
||||||
stream : FILEs)
|
|
||||||
return size_t;
|
|
||||||
pragma Import (C, C_fread, "fread");
|
|
||||||
|
|
||||||
begin
|
begin
|
||||||
return C_fread (buffer, size, count, stream);
|
return C_fread (buffer, size, count, stream);
|
||||||
end fread;
|
end fread;
|
||||||
|
@ -68,31 +84,25 @@ package body Interfaces.C_Streams is
|
||||||
-- fread --
|
-- 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
|
function fread
|
||||||
(buffer : voids;
|
(buffer : voids;
|
||||||
index : size_t;
|
index : size_t;
|
||||||
size : size_t;
|
size : size_t;
|
||||||
count : size_t;
|
count : size_t;
|
||||||
stream : FILEs)
|
stream : FILEs) return size_t
|
||||||
return size_t
|
|
||||||
is
|
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
|
begin
|
||||||
return C_fread
|
return C_fread
|
||||||
(To_Acc_Bytes (buffer) (index * size)'Address, size, count, stream);
|
(To_Acc_Bytes (buffer) (index * size)'Address, size, count, stream);
|
||||||
|
@ -106,17 +116,8 @@ package body Interfaces.C_Streams is
|
||||||
(buffer : voids;
|
(buffer : voids;
|
||||||
size : size_t;
|
size : size_t;
|
||||||
count : size_t;
|
count : size_t;
|
||||||
stream : FILEs)
|
stream : FILEs) return size_t
|
||||||
return size_t
|
|
||||||
is
|
is
|
||||||
function C_fwrite
|
|
||||||
(buffer : voids;
|
|
||||||
size : size_t;
|
|
||||||
count : size_t;
|
|
||||||
stream : FILEs)
|
|
||||||
return size_t;
|
|
||||||
pragma Import (C, C_fwrite, "fwrite");
|
|
||||||
|
|
||||||
begin
|
begin
|
||||||
return C_fwrite (buffer, size, count, stream);
|
return C_fwrite (buffer, size, count, stream);
|
||||||
end fwrite;
|
end fwrite;
|
||||||
|
@ -129,17 +130,8 @@ package body Interfaces.C_Streams is
|
||||||
(stream : FILEs;
|
(stream : FILEs;
|
||||||
buffer : chars;
|
buffer : chars;
|
||||||
mode : int;
|
mode : int;
|
||||||
size : size_t)
|
size : size_t) return int
|
||||||
return int
|
|
||||||
is
|
is
|
||||||
function C_setvbuf
|
|
||||||
(stream : FILEs;
|
|
||||||
buffer : chars;
|
|
||||||
mode : int;
|
|
||||||
size : size_t)
|
|
||||||
return int;
|
|
||||||
pragma Import (C, C_setvbuf, "setvbuf");
|
|
||||||
|
|
||||||
begin
|
begin
|
||||||
return C_setvbuf (stream, buffer, mode, size);
|
return C_setvbuf (stream, buffer, mode, size);
|
||||||
end setvbuf;
|
end setvbuf;
|
||||||
|
|
|
@ -370,7 +370,7 @@ package body Inline is
|
||||||
----------------------------
|
----------------------------
|
||||||
|
|
||||||
function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean 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;
|
Body_Ent : Entity_Id;
|
||||||
Ent : Entity_Id;
|
Ent : Entity_Id;
|
||||||
|
|
||||||
|
|
|
@ -881,6 +881,10 @@ package body Lib.Writ is
|
||||||
Write_Info_Str (" NS");
|
Write_Info_Str (" NS");
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
if Sec_Stack_Used then
|
||||||
|
Write_Info_Str (" SS");
|
||||||
|
end if;
|
||||||
|
|
||||||
if Unreserve_All_Interrupts then
|
if Unreserve_All_Interrupts then
|
||||||
Write_Info_Str (" UA");
|
Write_Info_Str (" UA");
|
||||||
end if;
|
end if;
|
||||||
|
|
|
@ -176,6 +176,9 @@ package Lib.Writ is
|
||||||
-- compiler, but is added by the Project Manager in gnatmake
|
-- compiler, but is added by the Project Manager in gnatmake
|
||||||
-- when an Interface ALI file is copied to the library
|
-- when an Interface ALI file is copied to the library
|
||||||
-- directory.
|
-- 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
|
-- Tx A valid Task_Dispatching_Policy pragma applies to all
|
||||||
-- the units in this file, where x is the first character
|
-- the units in this file, where x is the first character
|
||||||
|
|
|
@ -776,9 +776,8 @@ package body Lib.Xref is
|
||||||
and then Ent = Base_Type (Ent)
|
and then Ent = Base_Type (Ent)
|
||||||
and then In_Extended_Main_Source_Unit (Ent)
|
and then In_Extended_Main_Source_Unit (Ent)
|
||||||
then
|
then
|
||||||
|
|
||||||
declare
|
declare
|
||||||
Op_List : Elist_Id := Primitive_Operations (Ent);
|
Op_List : constant Elist_Id := Primitive_Operations (Ent);
|
||||||
Op : Elmt_Id;
|
Op : Elmt_Id;
|
||||||
Prim : Entity_Id;
|
Prim : Entity_Id;
|
||||||
|
|
||||||
|
@ -787,11 +786,10 @@ package body Lib.Xref is
|
||||||
-- through several derivations.
|
-- through several derivations.
|
||||||
|
|
||||||
function Parent_Op (E : Entity_Id) return Entity_Id is
|
function Parent_Op (E : Entity_Id) return Entity_Id is
|
||||||
Orig_Op : Entity_Id := Alias (E);
|
Orig_Op : constant Entity_Id := Alias (E);
|
||||||
begin
|
begin
|
||||||
if No (Orig_Op) then
|
if No (Orig_Op) then
|
||||||
return Empty;
|
return Empty;
|
||||||
|
|
||||||
elsif not Comes_From_Source (E)
|
elsif not Comes_From_Source (E)
|
||||||
and then not Has_Xref_Entry (Orig_Op)
|
and then not Has_Xref_Entry (Orig_Op)
|
||||||
and then Comes_From_Source (Orig_Op)
|
and then Comes_From_Source (Orig_Op)
|
||||||
|
@ -804,9 +802,7 @@ package body Lib.Xref is
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Op := First_Elmt (Op_List);
|
Op := First_Elmt (Op_List);
|
||||||
|
|
||||||
while Present (Op) loop
|
while Present (Op) loop
|
||||||
|
|
||||||
Prim := Parent_Op (Node (Op));
|
Prim := Parent_Op (Node (Op));
|
||||||
|
|
||||||
if Present (Prim) then
|
if Present (Prim) then
|
||||||
|
|
|
@ -139,7 +139,7 @@ const char *object_library_extension = ".a";
|
||||||
#elif defined (VMS)
|
#elif defined (VMS)
|
||||||
const char *object_file_option = "";
|
const char *object_file_option = "";
|
||||||
const char *run_path_option = "";
|
const char *run_path_option = "";
|
||||||
char shared_libgnat_default = SHARED;
|
char shared_libgnat_default = STATIC;
|
||||||
int link_max = 2147483647;
|
int link_max = 2147483647;
|
||||||
unsigned char objlist_file_supported = 0;
|
unsigned char objlist_file_supported = 0;
|
||||||
unsigned char using_gnu_linker = 0;
|
unsigned char using_gnu_linker = 0;
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- 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 --
|
-- 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- --
|
-- 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 Snames; use Snames;
|
||||||
with Switch; use Switch;
|
with Switch; use Switch;
|
||||||
with Switch.M; use Switch.M;
|
with Switch.M; use Switch.M;
|
||||||
with System.HTable;
|
|
||||||
with Targparm;
|
with Targparm;
|
||||||
with Tempdir;
|
with Tempdir;
|
||||||
|
|
||||||
with Ada.Exceptions; use Ada.Exceptions;
|
with Ada.Exceptions; use Ada.Exceptions;
|
||||||
with Ada.Command_Line; use Ada.Command_Line;
|
with Ada.Command_Line; use Ada.Command_Line;
|
||||||
|
|
||||||
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
|
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
|
||||||
with GNAT.Case_Util; use GNAT.Case_Util;
|
with GNAT.Case_Util; use GNAT.Case_Util;
|
||||||
|
|
||||||
|
with System.HTable;
|
||||||
|
|
||||||
package body Make is
|
package body Make is
|
||||||
|
|
||||||
use ASCII;
|
use ASCII;
|
||||||
|
@ -3265,7 +3266,7 @@ package body Make is
|
||||||
--------------------------
|
--------------------------
|
||||||
|
|
||||||
procedure Enter_Into_Obsoleted (F : Name_Id) 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;
|
First : Natural := Name'Last;
|
||||||
F2 : Name_Id := F;
|
F2 : Name_Id := F;
|
||||||
|
|
||||||
|
@ -3398,7 +3399,55 @@ package body Make is
|
||||||
Opt.Check_Object_Consistency := False;
|
Opt.Check_Object_Consistency := False;
|
||||||
end if;
|
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)
|
-- If the main project file is a library project file, main(s)
|
||||||
-- cannot be specified on the command line.
|
-- cannot be specified on the command line.
|
||||||
|
@ -3602,9 +3651,10 @@ package body Make is
|
||||||
-- all the sources of the project.
|
-- all the sources of the project.
|
||||||
|
|
||||||
declare
|
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
|
Prj.Util.Value_Of
|
||||||
(Name_Languages, Data.Decl.Attributes);
|
(Name_Languages, Data.Decl.Attributes);
|
||||||
|
|
||||||
|
@ -3661,31 +3711,12 @@ package body Make is
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
-- If we did not get any main, it means that all mains
|
-- If we did not get any main, it means that all mains
|
||||||
-- in attribute Mains are in a foreign language. So,
|
-- in attribute Mains are in a foreign language and -B
|
||||||
-- we put all sources of the main project in the Q.
|
-- was not specified to gnatmake; so, we fail.
|
||||||
|
|
||||||
if not At_Least_One_Main then
|
if not At_Least_One_Main then
|
||||||
|
Make_Failed
|
||||||
-- First make sure that the binder and the linker
|
("no Ada mains; use -B to build foreign main");
|
||||||
-- 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;
|
|
||||||
end if;
|
end if;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
@ -3698,7 +3729,7 @@ package body Make is
|
||||||
Write_Eol;
|
Write_Eol;
|
||||||
Write_Str ("GNATMAKE ");
|
Write_Str ("GNATMAKE ");
|
||||||
Write_Str (Gnatvsn.Gnat_Version_String);
|
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;
|
Write_Eol;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
@ -4563,6 +4594,7 @@ package body Make is
|
||||||
or not Do_Bind_Step
|
or not Do_Bind_Step
|
||||||
or not Is_Main_Unit)
|
or not Is_Main_Unit)
|
||||||
and then not No_Main_Subprogram
|
and then not No_Main_Subprogram
|
||||||
|
and then not Build_Bind_And_Link_Full_Project
|
||||||
then
|
then
|
||||||
if Osint.Number_Of_Files = 1 then
|
if Osint.Number_Of_Files = 1 then
|
||||||
exit Multiple_Main_Loop;
|
exit Multiple_Main_Loop;
|
||||||
|
@ -5995,7 +6027,7 @@ package body Make is
|
||||||
|
|
||||||
else
|
else
|
||||||
declare
|
declare
|
||||||
Name : String := Get_Name_String (F);
|
Name : constant String := Get_Name_String (F);
|
||||||
First : Natural := Name'Last;
|
First : Natural := Name'Last;
|
||||||
F2 : Name_Id := F;
|
F2 : Name_Id := F;
|
||||||
|
|
||||||
|
|
|
@ -61,6 +61,11 @@ begin
|
||||||
Write_Str (" -b Bind only");
|
Write_Str (" -b Bind only");
|
||||||
Write_Eol;
|
Write_Eol;
|
||||||
|
|
||||||
|
-- Line for -B
|
||||||
|
|
||||||
|
Write_Str (" -B Build, bind and link full project");
|
||||||
|
Write_Eol;
|
||||||
|
|
||||||
-- Line for -c
|
-- Line for -c
|
||||||
|
|
||||||
Write_Str (" -c Compile only");
|
Write_Str (" -c Compile only");
|
||||||
|
|
|
@ -59,12 +59,12 @@ package body MDLL is
|
||||||
|
|
||||||
Base_Filename : constant String := MDLL.Fil.Ext_To (Lib_Filename);
|
Base_Filename : constant String := MDLL.Fil.Ext_To (Lib_Filename);
|
||||||
|
|
||||||
Def_File : aliased String := Def_Filename;
|
Def_File : aliased constant String := Def_Filename;
|
||||||
Jnk_File : aliased String := Base_Filename & ".jnk";
|
Jnk_File : aliased String := Base_Filename & ".jnk";
|
||||||
Bas_File : aliased String := Base_Filename & ".base";
|
Bas_File : aliased constant String := Base_Filename & ".base";
|
||||||
Dll_File : aliased String := Base_Filename & ".dll";
|
Dll_File : aliased String := Base_Filename & ".dll";
|
||||||
Exp_File : aliased String := Base_Filename & ".exp";
|
Exp_File : aliased String := Base_Filename & ".exp";
|
||||||
Lib_File : aliased String := "lib" & Base_Filename & ".a";
|
Lib_File : aliased constant String := "lib" & Base_Filename & ".a";
|
||||||
|
|
||||||
Bas_Opt : aliased String := "-Wl,--base-file," & Bas_File;
|
Bas_Opt : aliased String := "-Wl,--base-file," & Bas_File;
|
||||||
Lib_Opt : aliased String := "-mdll";
|
Lib_Opt : aliased String := "-mdll";
|
||||||
|
@ -187,10 +187,13 @@ package body MDLL is
|
||||||
Utl.Gnatbind (L_Afiles, Options & Bargs_Options);
|
Utl.Gnatbind (L_Afiles, Options & Bargs_Options);
|
||||||
|
|
||||||
declare
|
declare
|
||||||
Params : OS_Lib.Argument_List :=
|
Params : constant OS_Lib.Argument_List :=
|
||||||
Out_Opt'Unchecked_Access & Jnk_File'Unchecked_Access &
|
Out_Opt'Unchecked_Access &
|
||||||
Lib_Opt'Unchecked_Access &
|
Jnk_File'Unchecked_Access &
|
||||||
Bas_Opt'Unchecked_Access & Ofiles & All_Options;
|
Lib_Opt'Unchecked_Access &
|
||||||
|
Bas_Opt'Unchecked_Access &
|
||||||
|
Ofiles &
|
||||||
|
All_Options;
|
||||||
begin
|
begin
|
||||||
Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
|
Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
|
||||||
end;
|
end;
|
||||||
|
@ -207,13 +210,14 @@ package body MDLL is
|
||||||
Utl.Gnatbind (L_Afiles, Options & Bargs_Options);
|
Utl.Gnatbind (L_Afiles, Options & Bargs_Options);
|
||||||
|
|
||||||
declare
|
declare
|
||||||
Params : OS_Lib.Argument_List :=
|
Params : constant OS_Lib.Argument_List :=
|
||||||
Out_Opt'Unchecked_Access & Jnk_File'Unchecked_Access &
|
Out_Opt'Unchecked_Access &
|
||||||
Lib_Opt'Unchecked_Access &
|
Jnk_File'Unchecked_Access &
|
||||||
Bas_Opt'Unchecked_Access &
|
Lib_Opt'Unchecked_Access &
|
||||||
Exp_File'Unchecked_Access &
|
Bas_Opt'Unchecked_Access &
|
||||||
Ofiles &
|
Exp_File'Unchecked_Access &
|
||||||
All_Options;
|
Ofiles &
|
||||||
|
All_Options;
|
||||||
begin
|
begin
|
||||||
Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
|
Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
|
||||||
end;
|
end;
|
||||||
|
@ -230,13 +234,14 @@ package body MDLL is
|
||||||
Utl.Gnatbind (L_Afiles, Options & Bargs_Options);
|
Utl.Gnatbind (L_Afiles, Options & Bargs_Options);
|
||||||
|
|
||||||
declare
|
declare
|
||||||
Params : OS_Lib.Argument_List :=
|
Params : constant OS_Lib.Argument_List :=
|
||||||
Out_Opt'Unchecked_Access & Dll_File'Unchecked_Access &
|
Out_Opt'Unchecked_Access &
|
||||||
Lib_Opt'Unchecked_Access &
|
Dll_File'Unchecked_Access &
|
||||||
Exp_File'Unchecked_Access &
|
Lib_Opt'Unchecked_Access &
|
||||||
Adr_Opt'Unchecked_Access &
|
Exp_File'Unchecked_Access &
|
||||||
Ofiles &
|
Adr_Opt'Unchecked_Access &
|
||||||
All_Options;
|
Ofiles &
|
||||||
|
All_Options;
|
||||||
begin
|
begin
|
||||||
Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
|
Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
|
||||||
end;
|
end;
|
||||||
|
@ -325,13 +330,14 @@ package body MDLL is
|
||||||
Utl.Gnatbind (L_Afiles, Options & Bargs_Options);
|
Utl.Gnatbind (L_Afiles, Options & Bargs_Options);
|
||||||
|
|
||||||
declare
|
declare
|
||||||
Params : OS_Lib.Argument_List :=
|
Params : constant OS_Lib.Argument_List :=
|
||||||
Out_Opt'Unchecked_Access & Dll_File'Unchecked_Access &
|
Out_Opt'Unchecked_Access &
|
||||||
Lib_Opt'Unchecked_Access &
|
Dll_File'Unchecked_Access &
|
||||||
Exp_File'Unchecked_Access &
|
Lib_Opt'Unchecked_Access &
|
||||||
Adr_Opt'Unchecked_Access &
|
Exp_File'Unchecked_Access &
|
||||||
Ofiles &
|
Adr_Opt'Unchecked_Access &
|
||||||
All_Options;
|
Ofiles &
|
||||||
|
All_Options;
|
||||||
begin
|
begin
|
||||||
Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
|
Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
|
||||||
end;
|
end;
|
||||||
|
|
|
@ -530,13 +530,19 @@ gnat_print_type (FILE *file, tree node, int indent)
|
||||||
}
|
}
|
||||||
|
|
||||||
static const char *
|
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));
|
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);
|
__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;
|
return (const char *) ada_name;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
@ -25,12 +25,14 @@
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
|
|
||||||
with ALI; use ALI;
|
with ALI; use ALI;
|
||||||
|
with Gnatvsn; use Gnatvsn;
|
||||||
with Hostparm;
|
with Hostparm;
|
||||||
with MLib.Fil; use MLib.Fil;
|
with MLib.Fil; use MLib.Fil;
|
||||||
with MLib.Tgt; use MLib.Tgt;
|
with MLib.Tgt; use MLib.Tgt;
|
||||||
with MLib.Utl; use MLib.Utl;
|
with MLib.Utl; use MLib.Utl;
|
||||||
with Namet; use Namet;
|
with Namet; use Namet;
|
||||||
with Opt;
|
with Opt;
|
||||||
|
with Osint; use Osint;
|
||||||
with Output; use Output;
|
with Output; use Output;
|
||||||
with Prj.Com; use Prj.Com;
|
with Prj.Com; use Prj.Com;
|
||||||
with Prj.Env; use Prj.Env;
|
with Prj.Env; use Prj.Env;
|
||||||
|
@ -1165,7 +1167,12 @@ package body MLib.Prj is
|
||||||
|
|
||||||
if Libgnarl_Needed then
|
if Libgnarl_Needed then
|
||||||
Opts.Increment_Last;
|
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;
|
end if;
|
||||||
|
|
||||||
if Libdecgnat_Needed then
|
if Libdecgnat_Needed then
|
||||||
|
@ -1177,7 +1184,12 @@ package body MLib.Prj is
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
Opts.Increment_Last;
|
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
|
-- If Path Option is supported, add the necessary switch with the
|
||||||
-- content of Rpath. As Rpath contains at least libgnat directory
|
-- content of Rpath. As Rpath contains at least libgnat directory
|
||||||
|
@ -1717,10 +1729,11 @@ package body MLib.Prj is
|
||||||
-- For fopen
|
-- For fopen
|
||||||
|
|
||||||
Status : Interfaces.C_Streams.int;
|
Status : Interfaces.C_Streams.int;
|
||||||
|
pragma Unreferenced (Status);
|
||||||
-- For fclose
|
-- For fclose
|
||||||
|
|
||||||
Begin_Info : String := "-- BEGIN Object file/option list";
|
Begin_Info : constant String := "-- BEGIN Object file/option list";
|
||||||
End_Info : String := "-- END Object file/option list ";
|
End_Info : constant String := "-- END Object file/option list ";
|
||||||
|
|
||||||
Next_Line : String (1 .. 1000);
|
Next_Line : String (1 .. 1000);
|
||||||
-- Current line value
|
-- Current line value
|
||||||
|
@ -1793,18 +1806,30 @@ package body MLib.Prj is
|
||||||
|
|
||||||
if Next_Line (1 .. Nlast) /= End_Info then
|
if Next_Line (1 .. Nlast) /= End_Info then
|
||||||
loop
|
loop
|
||||||
-- Disregard -static and -shared, as -shared will be used
|
-- Ignore -static and -shared, since -shared will be used
|
||||||
-- in any case.
|
-- 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
|
-- later, because they are also needed for non Stand-Alone shared
|
||||||
-- libraries.
|
-- 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
|
if Next_Line (1 .. Nlast) /= "-static" and then
|
||||||
Next_Line (1 .. Nlast) /= "-shared" and then
|
Next_Line (1 .. Nlast) /= "-shared" and then
|
||||||
Next_Line (1 .. Nlast) /= "-ldecgnat" and then
|
Next_Line (1 .. Nlast) /= "-ldecgnat" and then
|
||||||
Next_Line (1 .. Nlast) /= "-lgnarl" 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
|
then
|
||||||
if Next_Line (1) /= '-' then
|
if Next_Line (1) /= '-' then
|
||||||
|
|
||||||
|
@ -1838,6 +1863,7 @@ package body MLib.Prj is
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
Status := fclose (Fd);
|
Status := fclose (Fd);
|
||||||
|
-- Is it really right to ignore any close error ???
|
||||||
end Process_Binder_File;
|
end Process_Binder_File;
|
||||||
|
|
||||||
------------------
|
------------------
|
||||||
|
|
|
@ -137,7 +137,6 @@ package body MLib.Tgt is
|
||||||
|
|
||||||
function Is_Object_Ext (Ext : String) return Boolean is
|
function Is_Object_Ext (Ext : String) return Boolean is
|
||||||
pragma Unreferenced (Ext);
|
pragma Unreferenced (Ext);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
return False;
|
return False;
|
||||||
end Is_Object_Ext;
|
end Is_Object_Ext;
|
||||||
|
@ -148,7 +147,6 @@ package body MLib.Tgt is
|
||||||
|
|
||||||
function Is_C_Ext (Ext : String) return Boolean is
|
function Is_C_Ext (Ext : String) return Boolean is
|
||||||
pragma Unreferenced (Ext);
|
pragma Unreferenced (Ext);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
return False;
|
return False;
|
||||||
end Is_C_Ext;
|
end Is_C_Ext;
|
||||||
|
@ -159,7 +157,6 @@ package body MLib.Tgt is
|
||||||
|
|
||||||
function Is_Archive_Ext (Ext : String) return Boolean is
|
function Is_Archive_Ext (Ext : String) return Boolean is
|
||||||
pragma Unreferenced (Ext);
|
pragma Unreferenced (Ext);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
return False;
|
return False;
|
||||||
end Is_Archive_Ext;
|
end Is_Archive_Ext;
|
||||||
|
@ -179,7 +176,6 @@ package body MLib.Tgt is
|
||||||
|
|
||||||
function Library_Exists_For (Project : Project_Id) return Boolean is
|
function Library_Exists_For (Project : Project_Id) return Boolean is
|
||||||
pragma Unreferenced (Project);
|
pragma Unreferenced (Project);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
return False;
|
return False;
|
||||||
end Library_Exists_For;
|
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
|
function Library_File_Name_For (Project : Project_Id) return Name_Id is
|
||||||
pragma Unreferenced (Project);
|
pragma Unreferenced (Project);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
return No_Name;
|
return No_Name;
|
||||||
end Library_File_Name_For;
|
end Library_File_Name_For;
|
||||||
|
|
|
@ -165,6 +165,11 @@ package Opt is
|
||||||
-- Force brief error messages to standard error, even if verbose mode is
|
-- Force brief error messages to standard error, even if verbose mode is
|
||||||
-- set (so that main error messages go to standard output).
|
-- 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;
|
Check_Object_Consistency : Boolean := False;
|
||||||
-- GNATBIND, GNATMAKE
|
-- GNATBIND, GNATMAKE
|
||||||
-- Set to True to check whether every object file is consistent with
|
-- 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
|
-- of the original source code. Causes debugging information to be
|
||||||
-- written with respect to the generated code file that is written.
|
-- 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;
|
Display_Compilation_Progress : Boolean := False;
|
||||||
-- GNATMAKE
|
-- GNATMAKE
|
||||||
-- Set True (-d switch) to display information on progress while compiling
|
-- Set True (-d switch) to display information on progress while compiling
|
||||||
|
@ -767,6 +779,11 @@ package Opt is
|
||||||
-- GNATMAKE, GNATLINK
|
-- GNATMAKE, GNATLINK
|
||||||
-- Set to False when no run_path_option should be issued to the linker
|
-- 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;
|
Shared_Libgnat : Boolean;
|
||||||
-- GNATBIND
|
-- GNATBIND
|
||||||
-- Set to True if a shared libgnat is requested by using the -shared
|
-- Set to True if a shared libgnat is requested by using the -shared
|
||||||
|
|
|
@ -24,15 +24,17 @@
|
||||||
-- --
|
-- --
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
|
|
||||||
with Fmap; use Fmap;
|
with Fmap; use Fmap;
|
||||||
|
with Gnatvsn; use Gnatvsn;
|
||||||
with Hostparm;
|
with Hostparm;
|
||||||
with Namet; use Namet;
|
with Namet; use Namet;
|
||||||
with Opt; use Opt;
|
with Opt; use Opt;
|
||||||
with Output; use Output;
|
with Output; use Output;
|
||||||
with Sdefault; use Sdefault;
|
with Sdefault; use Sdefault;
|
||||||
with System.Case_Util; use System.Case_Util;
|
|
||||||
with Table;
|
with Table;
|
||||||
|
|
||||||
|
with System.Case_Util; use System.Case_Util;
|
||||||
|
|
||||||
with Unchecked_Conversion;
|
with Unchecked_Conversion;
|
||||||
|
|
||||||
with GNAT.OS_Lib; use GNAT.OS_Lib;
|
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 C_String_Length (S : Address) return Integer is
|
||||||
function Strlen (S : Address) return Integer;
|
function Strlen (S : Address) return Integer;
|
||||||
pragma Import (C, Strlen, "strlen");
|
pragma Import (C, Strlen, "strlen");
|
||||||
|
|
||||||
begin
|
begin
|
||||||
if S = Null_Address then
|
if S = Null_Address then
|
||||||
return 0;
|
return 0;
|
||||||
|
@ -646,7 +647,6 @@ package body Osint is
|
||||||
|
|
||||||
function Concat (String_One : String; String_Two : String) return String is
|
function Concat (String_One : String; String_Two : String) return String is
|
||||||
Buffer : String (1 .. String_One'Length + String_Two'Length);
|
Buffer : String (1 .. String_One'Length + String_Two'Length);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Buffer (1 .. String_One'Length) := String_One;
|
Buffer (1 .. String_One'Length) := String_One;
|
||||||
Buffer (String_One'Length + 1 .. Buffer'Last) := String_Two;
|
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
|
procedure Exit_Program (Exit_Code : Exit_Code_Type) is
|
||||||
begin
|
begin
|
||||||
-- The program will exit with the following status:
|
-- The program will exit with the following status:
|
||||||
|
|
||||||
-- 0 if the object file has been generated (with or without warnings)
|
-- 0 if the object file has been generated (with or without warnings)
|
||||||
-- 1 if recompilation was not needed (smart recompilation)
|
-- 1 if recompilation was not needed (smart recompilation)
|
||||||
-- 2 if gnat1 has been killed by a signal (detected by GCC)
|
-- 2 if gnat1 has been killed by a signal (detected by GCC)
|
||||||
-- 4 for a fatal error
|
-- 4 for a fatal error
|
||||||
-- 5 if there were errors
|
-- 5 if there were errors
|
||||||
-- 6 if no code has been generated (spec)
|
-- 6 if no code has been generated (spec)
|
||||||
--
|
|
||||||
-- Note that exit code 3 is not used and must not be used as this is
|
-- 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
|
-- the code returned by a program aborted via C abort() routine on
|
||||||
-- Windows. GCC checks for that case and thinks that the child process
|
-- Windows. GCC checks for that case and thinks that the child process
|
||||||
|
@ -1205,9 +1206,9 @@ package body Osint is
|
||||||
return null;
|
return null;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
else
|
-- Search in the current directory
|
||||||
-- Search in the current directory
|
|
||||||
|
|
||||||
|
else
|
||||||
-- Get the current directory
|
-- Get the current directory
|
||||||
|
|
||||||
declare
|
declare
|
||||||
|
@ -1845,7 +1846,7 @@ package body Osint is
|
||||||
-- Start of processing for Read_Default_Search_Dirs
|
-- Start of processing for Read_Default_Search_Dirs
|
||||||
|
|
||||||
begin
|
begin
|
||||||
-- Construct a C compatible character string buffer.
|
-- Construct a C compatible character string buffer
|
||||||
|
|
||||||
Buffer (1 .. Search_Dir_Prefix.all'Length)
|
Buffer (1 .. Search_Dir_Prefix.all'Length)
|
||||||
:= Search_Dir_Prefix.all;
|
:= Search_Dir_Prefix.all;
|
||||||
|
@ -1940,7 +1941,7 @@ package body Osint is
|
||||||
-- indicates failure to open the specified source file.
|
-- indicates failure to open the specified source file.
|
||||||
|
|
||||||
Text : Text_Buffer_Ptr;
|
Text : Text_Buffer_Ptr;
|
||||||
-- Allocated text buffer.
|
-- Allocated text buffer
|
||||||
|
|
||||||
Status : Boolean;
|
Status : Boolean;
|
||||||
-- For the calls to Close
|
-- For the calls to Close
|
||||||
|
@ -2001,23 +2002,7 @@ package body Osint is
|
||||||
else
|
else
|
||||||
Current_Full_Obj_Stamp := Empty_Time_Stamp;
|
Current_Full_Obj_Stamp := Empty_Time_Stamp;
|
||||||
Close (Lib_FD, Status);
|
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
|
-- No need to check the status, we return null anyway
|
||||||
|
|
||||||
return null;
|
return null;
|
||||||
|
@ -2183,6 +2168,7 @@ package body Osint is
|
||||||
-- Read is complete, get time stamp and close file and we are done
|
-- Read is complete, get time stamp and close file and we are done
|
||||||
|
|
||||||
Close (Source_File_FD, Status);
|
Close (Source_File_FD, Status);
|
||||||
|
|
||||||
-- The status should never be False. But, if it is, what can we do?
|
-- The status should never be False. But, if it is, what can we do?
|
||||||
-- So, we don't test it.
|
-- So, we don't test it.
|
||||||
|
|
||||||
|
@ -2206,6 +2192,7 @@ package body Osint is
|
||||||
Std_Prefix := Executable_Prefix;
|
Std_Prefix := Executable_Prefix;
|
||||||
|
|
||||||
if Std_Prefix.all /= "" then
|
if Std_Prefix.all /= "" then
|
||||||
|
|
||||||
-- Remove trailing directory separator when calling set_std_prefix
|
-- Remove trailing directory separator when calling set_std_prefix
|
||||||
|
|
||||||
set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1);
|
set_std_prefix (Std_Prefix.all, Std_Prefix'Length - 1);
|
||||||
|
@ -2240,6 +2227,31 @@ package body Osint is
|
||||||
Running_Program := P;
|
Running_Program := P;
|
||||||
end Set_Program;
|
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 --
|
-- Smart_File_Stamp --
|
||||||
----------------------
|
----------------------
|
||||||
|
@ -2317,9 +2329,11 @@ package body Osint is
|
||||||
Get_Name_String (Name);
|
Get_Name_String (Name);
|
||||||
|
|
||||||
for J in reverse 1 .. Name_Len - 1 loop
|
for J in reverse 1 .. Name_Len - 1 loop
|
||||||
|
|
||||||
-- If we find the last directory separator
|
-- If we find the last directory separator
|
||||||
|
|
||||||
if Is_Directory_Separator (Name_Buffer (J)) then
|
if Is_Directory_Separator (Name_Buffer (J)) then
|
||||||
|
|
||||||
-- Return the part of Name that follows this last directory
|
-- Return the part of Name that follows this last directory
|
||||||
-- separator.
|
-- separator.
|
||||||
|
|
||||||
|
@ -2344,8 +2358,7 @@ package body Osint is
|
||||||
|
|
||||||
for J in reverse 2 .. Name_Len loop
|
for J in reverse 2 .. Name_Len loop
|
||||||
|
|
||||||
-- If we found the last '.', return the part of Name that precedes
|
-- If we found the last '.', return part of Name that precedes it
|
||||||
-- this '.'.
|
|
||||||
|
|
||||||
if Name_Buffer (J) = '.' then
|
if Name_Buffer (J) = '.' then
|
||||||
Name_Len := J - 1;
|
Name_Len := J - 1;
|
||||||
|
@ -2595,7 +2608,7 @@ package body Osint is
|
||||||
Path_Len : Integer) return String_Access
|
Path_Len : Integer) return String_Access
|
||||||
is
|
is
|
||||||
subtype Path_String is String (1 .. Path_Len);
|
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
|
function Address_To_Access is new
|
||||||
Unchecked_Conversion (Source => Address,
|
Unchecked_Conversion (Source => Address,
|
||||||
|
@ -2604,7 +2617,7 @@ package body Osint is
|
||||||
Path_Access : constant Path_String_Access :=
|
Path_Access : constant Path_String_Access :=
|
||||||
Address_To_Access (Path_Addr);
|
Address_To_Access (Path_Addr);
|
||||||
|
|
||||||
Return_Val : String_Access;
|
Return_Val : String_Access;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Return_Val := new String (1 .. Path_Len);
|
Return_Val := new String (1 .. Path_Len);
|
||||||
|
@ -2669,7 +2682,6 @@ package body Osint is
|
||||||
Name_Buffer (1 .. Name_Len);
|
Name_Buffer (1 .. Name_Len);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
|
|
||||||
Find_Program_Name;
|
Find_Program_Name;
|
||||||
|
|
||||||
-- Convert the name to lower case so error messages are the same on
|
-- Convert the name to lower case so error messages are the same on
|
||||||
|
|
|
@ -213,6 +213,12 @@ package Osint is
|
||||||
-- If the above computation fails, return Path.
|
-- If the above computation fails, return Path.
|
||||||
-- This function assumes that Prefix'First = Path'First
|
-- 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 --
|
-- Search Dir Routines --
|
||||||
-------------------------
|
-------------------------
|
||||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue