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