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;
(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
---------
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);
------------------
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;
------------------
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;
-------------------
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;
-------------
function Get_Pid
- (Descriptor : Process_Descriptor)
- return Process_Id
+ (Descriptor : Process_Descriptor) return Process_Id
is
begin
return Descriptor.Pid;
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");
----------
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);
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;
-----------------
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;
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
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
-- 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
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 --
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
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
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;
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
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;
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;
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);
---------------------
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;
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);
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);
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
(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;
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;
(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;
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;
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);
-- 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;
if C_Msg = C.Strings.Null_Ptr then
return "Unknown system error";
-
else
return C.Strings.Value (C_Msg);
end if;
-- 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- --
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;
-- 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- --
-- 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;
-- --
-- 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- --
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;
-- empty (St = OK) or have left it empty.
St := semTake (S.Sema, NO_WAIT);
+ pragma Assert (St = OK);
end Set_False;
--------------
procedure Set_True (S : in out Suspension_Object) is
St : STATUS;
-
+ pragma Unreferenced (St);
begin
St := semGive (S.Sema);
end Set_True;
procedure Finalize (S : in out Suspension_Object) is
St : STATUS;
-
+ pragma Unreferenced (St);
begin
St := semDelete (S.Sema);
St := semDelete (S.Mutex);
procedure Finalize_Lock (L : access Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_destroy (L.Mutex'Access);
pragma Assert (Result = 0);
procedure Finalize_Lock (L : access RTS_Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
(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);
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);
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);
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
-
Result : Interfaces.C.int;
begin
(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;
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);
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);
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);
procedure Yield (Do_Yield : Boolean := True) is
Result : Interfaces.C.int;
-
+ pragma Unreferenced (Result);
begin
if Do_Yield then
Result := sched_yield;
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
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));
is
pragma Unreferenced (T);
pragma Unreferenced (Thread_Self);
-
begin
return False;
end Suspend_Task;
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;
-- 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.
-- 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- --
-- 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;
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;
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);
procedure Yield (Do_Yield : Boolean := True) is
Result : Interfaces.C.int;
+ pragma Unreferenced (Result);
begin
if Do_Yield then
Result := sched_yield;
procedure Abort_Task (T : Task_ID) is
Result : Interfaces.C.int;
-
begin
Result :=
pthread_kill
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);
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);
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
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);
-- --
------------------------------------------------------------------------------
--- 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.
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
pragma Unreferenced (On);
pragma Unreferenced (T);
-
begin
null;
end Stack_Guard;
procedure Finalize_Lock (L : access Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
procedure Finalize_Lock (L : access RTS_Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
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
procedure Unlock (L : access Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_unlock (L);
pragma Assert (Result = 0);
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);
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);
procedure Yield (Do_Yield : Boolean := True) is
Result : Interfaces.C.int;
-
+ pragma Unreferenced (Result);
begin
if Do_Yield then
Result := sched_yield;
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
-- --
-- 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- --
-------------------------------------
function Has_Interrupt_Or_Attach_Handler
- (Object : access Dynamic_Interrupt_Protection)
- return Boolean
+ (Object : access Dynamic_Interrupt_Protection) return Boolean
is
pragma Unreferenced (Object);
-
begin
return True;
end Has_Interrupt_Or_Attach_Handler;
-------------------------------------
function Has_Interrupt_Or_Attach_Handler
- (Object : access Static_Interrupt_Protection)
- return Boolean
+ (Object : access Static_Interrupt_Protection) return Boolean
is
pragma Unreferenced (Object);
-
begin
return True;
end Has_Interrupt_Or_Attach_Handler;
-- 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;
---------------
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;
-- 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
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
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;
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;
Reason : System.Tasking.Task_States)
is
Result : Interfaces.C.int;
-
begin
Result := pthread_cond_signal (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
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
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
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
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
procedure Yield (Do_Yield : Boolean := True) is
Result : Interfaces.C.int;
-
+ pragma Unreferenced (Result);
begin
if Do_Yield then
Result := sched_yield;
(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
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"
------------------
function C_Call_Chain
- (Traceback : System.Address;
- Max_Len : Natural)
- return Natural
+ (Traceback : System.Address;
+ Max_Len : Natural) return Natural
is
Val : Natural;
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,
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);
procedure Yield (Do_Yield : Boolean := True) is
Result : Interfaces.C.int;
pragma Unreferenced (Result);
-
begin
if Do_Yield then
Result := sched_yield;
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
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
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
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;
------------
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);
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.
is
pragma Unreferenced (Loss_Of_Inheritance);
- Result : Interfaces.C.int;
+ Result : Interfaces.C.int;
+ pragma Unreferenced (Result);
+
Param : aliased struct_pcparms;
use Task_Info;
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
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
--- 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
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;
-- --
-- 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- --
procedure Allocate_New_AST_Server is
Dummy : AST_Server_Task_Ptr;
+ pragma Unreferenced (Dummy);
begin
if Num_AST_Servers = Max_AST_Servers then
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;
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
-- --
-- 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- --
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;
-- --
-- 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- --
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.
Ptr := Registered_Handler_Head;
- while (Ptr /= null) loop
+ while Ptr /= null loop
if Ptr.H = Fat.Handler_Addr then
return True;
end if;
(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.
Ignored (Interrupt) := False;
- Old_Handler := User_Handler (Interrupt).H;
-
-- The new handler
User_Handler (Interrupt).H := null;
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
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
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
--- 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;
pragma Unreferenced (Lib_Address);
pragma Unreferenced (Relocatable);
-
-
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
Fil.Ext_To (Lib_Filename, DLL_Ext);
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
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;
begin
if Symbol_Data.Symbol_File = No_Name then
return "symvec.opt";
-
else
return Get_Name_String (Symbol_Data.Symbol_File);
end if;
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;
declare
Index : Natural := Opts'First;
Opt : String_Access;
+
begin
while Index <= Last_Opt loop
Opt := Opts (Index);
-- --
-- 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- --
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;
---------------------------------
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;
-- 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.
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
pragma Unreferenced (T);
pragma Unreferenced (On);
-
begin
null;
end Stack_Guard;
procedure Finalize_Lock (L : access Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_destroy (L.L'Access);
pragma Assert (Result = 0);
procedure Finalize_Lock (L : access RTS_Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
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)
Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
-
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_lock (L);
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);
procedure Unlock (L : access Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_unlock (L.L'Access);
pragma Assert (Result = 0);
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);
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);
(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);
Result : Interfaces.C.int;
Status : Cond_Value_Type;
+ -- The body below requires more comments ???
+
begin
Timedout := False;
Yielded := False;
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;
Lock_RTS;
end if;
+ -- More comments required in body below ???
+
SSL.Abort_Defer.all;
Write_Lock (Self_ID);
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;
if not Yielded then
Result := sched_yield;
+ pragma Assert (Result = 0);
end if;
SSL.Abort_Undefer.all;
procedure Yield (Do_Yield : Boolean := True) is
Result : Interfaces.C.int;
-
+ pragma Unreferenced (Result);
begin
if Do_Yield then
Result := sched_yield;
----------------------
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);
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);
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;
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);
-- 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.
----------------
procedure Initialize (Environment_Task : Task_ID) is
- Res : BOOL;
+ Discard : BOOL;
+ pragma Unreferenced (Discard);
begin
Environment_Task_ID := Environment_Task;
-- Here we need Annex E semantics, switch the current process to the
-- High_Priority_Class.
- Res :=
+ Discard :=
OS_Interface.SetPriorityClass
(GetCurrentProcess, High_Priority_Class);
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
--- 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;
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)
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 --
------------------------
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
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
-- 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;
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
-- --
-- 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- --
--------------------------------
-- 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
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
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;
Ptr := Registered_Handler_Head;
- while (Ptr /= null) loop
+ while Ptr /= null loop
if Ptr.H = Fat.Handler_Addr then
return True;
end if;
-- 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));
-- --
-- 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- --
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);
-- Archive_Ext --
-----------------
- function Archive_Ext return String is
+ function Archive_Ext return String is
begin
return "a";
end Archive_Ext;
-----------------------------
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;
procedure Yield (Do_Yield : Boolean := True) is
pragma Unreferenced (Do_Yield);
-
Result : int;
-
+ pragma Unreferenced (Result);
begin
Result := taskDelay (0);
end Yield;
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
--- 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;
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;
-----------------------
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
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;
--------------------
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;
(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;
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 --
-------------------------------
-------------------
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;
------------------
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;
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;
-- --
-- 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- --
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 --
------------
(buffer : voids;
size : size_t;
count : size_t;
- stream : FILEs)
- return size_t
+ stream : FILEs) return size_t
is
Get_Count : size_t := 0;
+
type Buffer_Type is array (size_t range 1 .. count,
size_t range 1 .. size) of Character;
type Buffer_Access is access Buffer_Type;
function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
- BA : Buffer_Access := To_BA (buffer);
+
+ BA : constant Buffer_Access := To_BA (buffer);
Ch : int;
- begin
+ begin
-- This Fread goes with the Fwrite below.
-- The C library fread sometimes can't read fputc generated files.
for C in 1 .. count loop
for S in 1 .. size loop
Ch := fgetc (stream);
+
if Ch = EOF then
return Get_Count;
end if;
+
BA.all (C, S) := Character'Val (Ch);
end loop;
+
Get_Count := Get_Count + 1;
end loop;
+
return Get_Count;
end fread;
index : size_t;
size : size_t;
count : size_t;
- stream : FILEs)
- return size_t
+ stream : FILEs) return size_t
is
Get_Count : size_t := 0;
+
type Buffer_Type is array (size_t range 1 .. count,
size_t range 1 .. size) of Character;
type Buffer_Access is access Buffer_Type;
function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
- BA : Buffer_Access := To_BA (buffer);
+
+ BA : constant Buffer_Access := To_BA (buffer);
Ch : int;
- begin
+ begin
-- This Fread goes with the Fwrite below.
-- The C library fread sometimes can't read fputc generated files.
for C in 1 + index .. count + index loop
for S in 1 .. size loop
Ch := fgetc (stream);
+
if Ch = EOF then
return Get_Count;
end if;
+
BA.all (C, S) := Character'Val (Ch);
end loop;
+
Get_Count := Get_Count + 1;
end loop;
+
return Get_Count;
end fread;
(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.
return Put_Count;
end if;
end loop;
+
Put_Count := Put_Count + 1;
end loop;
+
return Put_Count;
end fwrite;
(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
procedure Yield (Do_Yield : Boolean := True) is
Result : Interfaces.C.int;
-
+ pragma Unreferenced (Result);
begin
if Do_Yield then
Result := sched_yield;
-- --
-- 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- --
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);
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);
+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.
# 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))),)
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
-$(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 \
$(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); \
-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) \
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)" \
$(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) \
$(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 \
$(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 \
#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
g-pehage$(objext) \
g-regexp$(objext) \
g-regpat$(objext) \
+ g-sestin$(objext) \
g-soccon$(objext) \
g-socket$(objext) \
g-socthi$(objext) \
-- 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- --
-- 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);
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;
Task_Dispatching_Policy_Specified := ' ';
Unreserve_All_Interrupts_Specified := False;
Zero_Cost_Exceptions_Specified := False;
-
end Initialize_ALI;
--------------
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
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 --
---------------------
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
Normalize_Scalars_Specified := True;
NS_Found := True;
+ -- Invalid switch starting with N
+
else
Fatal_Error;
end if;
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
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
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
declare
Nested_Brackets : Natural := 0;
- C : Character;
begin
loop
end if;
end case;
- C := Getc;
+ Skipc;
end loop;
end;
Current_File_Num := XR.File_Num;
P := P + 1;
N := Get_Nat;
-
else
XR.File_Num := Current_File_Num;
end if;
XE.Last_Xref := Xref.Last;
C := Nextc;
-
end Read_Refs_For_One_Entity;
end loop;
-- --
-- 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- --
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;
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 ("");
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)
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 ("");
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;
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
----------------------------
procedure Public_Version_Warning is
-
Time : constant Int := Time_From_Last_Bind;
-- Constants to help defining periods
-- 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;
-- --
-- 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- --
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");
-- --
-- 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- --
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)
-- 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.
(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.
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;
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)));
-- in expressions.
if Item_Name = Snames.Name_Default_Switches then
- Default_Switches_Project := Project;
Default_Switches_Package := Pkg;
Default_Switches_Language := Index;
-- 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);
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
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;
(Static : Boolean;
Value : String_Access;
Last : Natural;
- Default : String)
- return String
+ Default : String) return String
is
begin
if Static then
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;
N_Full_Type_Declaration
then
declare
- Type_Def : Node_Id :=
+ Type_Def : constant Node_Id :=
Type_Definition
(Original_Node (Parent (T_Typ)));
begin
-- --
-- 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- --
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
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.
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;
-- 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
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.
-- 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;
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++)
end Entry_Index_Type;
---------------------
- -- First_Component --
+ -- 1 --
---------------------
function First_Component (Id : E) return E 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);
-- 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.
-- 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
-- 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.
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
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);
-- 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);
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;
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.
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);
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;
-- 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);
-- --
-- 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- --
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
-- 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:
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;
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;
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.
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 --
-- 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));
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,
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);
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
-- 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;
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;
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);
-- 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)
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
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
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)
------------------------------------
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)
and then Chars (Ritem) = Name_Attach_Handler
then
declare
- Handler : constant Node_Id :=
- First (Pragma_Argument_Associations (Ritem));
- Interrupt : constant Node_Id :=
- Next (Handler);
- Expr : Node_Id := Expression (Interrupt);
+ Handler : constant Node_Id :=
+ First (Pragma_Argument_Associations (Ritem));
- begin
+ Interrupt : constant Node_Id := Next (Handler);
+ Expr : constant Node_Id := Expression (Interrupt);
+ begin
Append_To (Table,
Make_Aggregate (Loc, Expressions => New_List (
Unchecked_Convert_To
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 --
-------------------------------
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 --
----------------------------
-- 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.
-- 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
* *
* 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- *
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: */
extern Uint Error_Msg_Uint_1;
extern Uint Error_Msg_Uint_2;
-
/* exp_code: */
#define Asm_Input_Constraint exp_code__asm_input_constraint
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
-- --
-- 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- --
-- 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;
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
-- --
-- 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- --
-- Ada form based literal
- elsif C = '#' or C = ':' then
+ elsif C = '#' or else C = ':' then
Base := Res;
Res := 0;
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
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
function Basename
(Path : Path_Name;
- Suffix : String := "")
- return String
+ Suffix : String := "") return String
is
Cut_Start : Natural :=
Strings.Fixed.Index
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");
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;
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
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;
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:
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
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
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
-- --
-- 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- --
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.
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;
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
-- --
-- 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- --
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;
-- --
-- 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- --
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
----------------
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;
(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;
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;
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;
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
-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;
---------------
procedure Gnatfind is
-
Output_Ref : Boolean := False;
Pattern : Xref_Lib.Search_Pattern;
Local_Symbols : Boolean := True;
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;
-- --
-- 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- --
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;
--
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;
-- "Make" an alternate sublibrary for each default sublibrary.
for Dirs in 1 .. Object_Dirs loop
-
Make_Args (1) :=
new String'("-C");
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);
when Set =>
- -- Validate arguments.
+ -- Validate arguments
if Lib_Dir = null then
Put_Line (Standard_Error,
Exit_Program (E_Fatal);
end if;
- -- Give instructions.
+ -- Give instructions
Put_Line ("Copy the contents of "
& ADC_File.all & " into your GNAT.ADC file");
when Delete =>
- -- Give instructions.
+ -- Give instructions
Put_Line ("GNAT Librarian DELETE not yet implemented.");
Put_Line ("Use appropriate system tools to remove library");
-- --
-- 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- --
-- Gnatlink usage: please consult the gnat documentation
-with Ada.Exceptions; use Ada.Exceptions;
with ALI; use ALI;
with Gnatvsn; use Gnatvsn;
with Hostparm;
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;
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;
---------------
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
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
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;
-- 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
-- --
-- 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- --
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
------------------------------
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
-- 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
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);
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:");
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;
end;
end loop;
- -- All done. Set proper exit status.
+ -- All done. Set proper exit status
Namet.Finalize;
Exit_Program (E_Success);
-
end Gnatls;
-- --
-- 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- --
-- 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;
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");
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 =>
Result : Integer;
+ -- Start of processing for Lt
+
begin
for S in Sort_Order'Range loop
Result := Apply_Sort_Criterion (Sort_Order (S));
-- --
-- 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- --
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,
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,
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,
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;
exception
when Invalid_Switch =>
Fail ("invalid switch " & Full_Switch);
-
end Scan_Args;
-----------
-- --
-- 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- --
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;
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;
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,
-- --
-- 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- --
when ASCII.NUL =>
exit;
- when 'a' =>
+ when 'a' =>
if GNAT.Command_Line.Full_Switch = "a" then
Read_Only := True;
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
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, " &
-- --
-- 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- --
procedure Extend (Dir : String) is
procedure Recursive_Extend (D : String);
- -- Recursively display all subdirectories of D.
+ -- Recursively display all subdirectories of D
----------------------
-- Recursive_Extend --
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
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
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;
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
-with Ada.Text_IO; use Ada.Text_IO;
-
with Csets;
with Err_Vars; use Err_Vars;
with Errutil;
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
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 --
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
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;
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 --
------------
(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;
-- 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);
(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;
(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;
----------------------------
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;
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;
-- 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
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;
-- 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)
begin
Op := First_Elmt (Op_List);
-
while Present (Op) loop
-
Prim := Parent_Op (Node (Op));
if Present (Prim) then
#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;
-- --
-- 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- --
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;
--------------------------
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;
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.
-- 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);
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;
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;
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;
else
declare
- Name : String := Get_Name_String (F);
+ Name : constant String := Get_Name_String (F);
First : Natural := Name'Last;
F2 : Name_Id := F;
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");
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";
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;
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;
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;
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;
}
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;
}
------------------------------------------------------------------------------
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;
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
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
-- 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
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
end if;
Status := fclose (Fd);
+ -- Is it really right to ignore any close error ???
end Process_Binder_File;
------------------
function Is_Object_Ext (Ext : String) return Boolean is
pragma Unreferenced (Ext);
-
begin
return False;
end Is_Object_Ext;
function Is_C_Ext (Ext : String) return Boolean is
pragma Unreferenced (Ext);
-
begin
return False;
end Is_C_Ext;
function Is_Archive_Ext (Ext : String) return Boolean is
pragma Unreferenced (Ext);
-
begin
return False;
end Is_Archive_Ext;
function Library_Exists_For (Project : Project_Id) return Boolean is
pragma Unreferenced (Project);
-
begin
return False;
end Library_Exists_For;
function Library_File_Name_For (Project : Project_Id) return Name_Id is
pragma Unreferenced (Project);
-
begin
return No_Name;
end Library_File_Name_For;
-- 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
-- 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
-- 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
-- --
------------------------------------------------------------------------------
-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;
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;
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;
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
return null;
end if;
- else
- -- Search in the current directory
+ -- Search in the current directory
+ else
-- Get the current directory
declare
-- 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;
-- 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
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;
-- 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.
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);
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 --
----------------------
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.
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;
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,
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);
Name_Buffer (1 .. Name_Len);
begin
-
Find_Program_Name;
-- Convert the name to lower case so error messages are the same on
-- 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 --
-------------------------
function Is_Illegal_Suffix
(Suffix : String;
- Dot_Replacement_Is_A_Single_Dot : Boolean)
- return Boolean;
+ Dot_Replacement_Is_A_Single_Dot : Boolean) return Boolean;
-- Returns True if the string Suffix cannot be used as
-- a spec suffix, a body suffix or a separate suffix.
function Path_Name_Of
(File_Name : Name_Id;
- Directory : Name_Id)
- return String;
+ Directory : Name_Id) return String;
-- Returns the path name of a (non project) file.
-- Returns an empty string if file cannot be found.
function Project_Extends
(Extending : Project_Id;
- Extended : Project_Id)
- return Boolean;
+ Extended : Project_Id) return Boolean;
-- Returns True if Extending is extending directly or indirectly Extended.
procedure Check_Naming_Scheme
function Is_Illegal_Suffix
(Suffix : String;
- Dot_Replacement_Is_A_Single_Dot : Boolean)
- return Boolean
+ Dot_Replacement_Is_A_Single_Dot : Boolean) return Boolean
is
begin
if Suffix'Length = 0 or else Index (Suffix, ".") = 0 then
----------------------
procedure Find_Source_Dirs (From : Name_Id; Location : Source_Ptr) is
- Directory : constant String := Get_Name_String (From);
+ Directory : constant String := Get_Name_String (From);
+ Element : String_Element;
+
Canonical_Directory_Id : Name_Id;
- Element : String_Element;
+ pragma Unreferenced (Canonical_Directory_Id);
+ -- Is this in fact being used for anything useful ???
procedure Recursive_Find_Dirs (Path : Name_Id);
- -- Find all the subdirectories (recursively) of Path
- -- and add them to the list of source directories
- -- of the project.
+ -- Find all the subdirectories (recursively) of Path and add them
+ -- to the list of source directories of the project.
-------------------------
-- Recursive_Find_Dirs --
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
declare
- The_Path : String :=
+ The_Path : constant String :=
Normalize_Pathname
(Name => Name_Buffer (1 .. Name_Len)) &
- Directory_Separator;
+ Directory_Separator;
+
The_Path_Last : constant Natural :=
Compute_Directory_Last (The_Path);
+
begin
Name_Len := The_Path_Last - The_Path'First + 1;
Name_Buffer (1 .. Name_Len) :=
Get_Name_String (From);
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+
-- Directory := Name_Buffer (1 .. Name_Len);
+ -- Why is above line commented out ???
+
Canonical_Directory_Id := Name_Find;
+ -- What is purpose of above assignment ???
+ -- Are we sure it is being used ???
if Current_Verbosity = High then
Write_Str (Directory);
function Path_Name_Of
(File_Name : Name_Id;
- Directory : Name_Id)
- return String
+ Directory : Name_Id) return String
is
Result : String_Access;
The_Directory : constant String := Get_Name_String (Directory);
function Project_Extends
(Extending : Project_Id;
- Extended : Project_Id)
- return Boolean
+ Extended : Project_Id) return Boolean
is
Current : Project_Id := Extending;
begin
-------------------------------
procedure Write_End_Of_Line_Comment (Node : Project_Node_Id) is
- Value : Name_Id := End_Of_Line_Comment (Node);
+ Value : constant Name_Id := End_Of_Line_Comment (Node);
+
begin
if Value /= No_Name then
Write_String (" --");
Attribute_Or_Array_Name => Name_Executable,
In_Package => Builder_Package);
- Executable_Suffix : Variable_Value :=
+ Executable_Suffix : constant Variable_Value :=
Prj.Util.Value_Of
(Name => Main,
Attribute_Or_Array_Name =>
-- the specification suffix.
declare
- Name : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
+ Name : constant String (1 .. Name_Len) :=
+ Name_Buffer (1 .. Name_Len);
Last : Positive := Name_Len;
Naming : constant Naming_Data :=
if S /= "not found"
or else not Configurable_Run_Time_Mode
+ or else All_Errors_Mode
then
M (1 .. 6) := "\file ";
P := 6;
return;
end if;
+ -- Note if secondary stack is used
+
+ if U_Id = System_Secondary_Stack then
+ Opt.Sec_Stack_Used := True;
+ end if;
+
-- Otherwise we need to load the unit, First build unit name
-- from the enumeration literal name in type RTU_Id.
---------------------
function Current_Handler
- (Interrupt : Interrupt_ID)
- return Parameterless_Handler
+ (Interrupt : Interrupt_ID) return Parameterless_Handler
is
begin
if Is_Reserved (Interrupt) then
-- Need comments as to why these always return True
function Has_Interrupt_Or_Attach_Handler
- (Object : access Dynamic_Interrupt_Protection)
- return Boolean
+ (Object : access Dynamic_Interrupt_Protection) return Boolean
is
pragma Unreferenced (Object);
-
begin
return True;
end Has_Interrupt_Or_Attach_Handler;
function Has_Interrupt_Or_Attach_Handler
- (Object : access Static_Interrupt_Protection)
- return Boolean
+ (Object : access Static_Interrupt_Protection) return Boolean
is
pragma Unreferenced (Object);
-
begin
return True;
end Has_Interrupt_Or_Attach_Handler;
------------------
function Unblocked_By
- (Interrupt : Interrupt_ID)
- return System.Tasking.Task_ID
+ (Interrupt : Interrupt_ID) return System.Tasking.Task_ID
is
begin
if Is_Reserved (Interrupt) then
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
------------------------------------------------------------------------------
with System.Storage_Elements;
+with System.Soft_Links;
with Unchecked_Conversion;
package SSE renames System.Storage_Elements;
use type SSE.Storage_Offset;
+ -- Even though these storage pools are typically only used
+ -- by a single task, if multiple tasks are declared at the
+ -- same or a more nested scope as the storage pool, there
+ -- still may be concurrent access. The current implementation
+ -- of Stack_Bounded_Pool always uses a global lock for protecting
+ -- access. This should eventually be replaced by an atomic
+ -- linked list implementation for efficiency reasons.
+
+ package SSL renames System.Soft_Links;
+
type Storage_Count_Access is access SSE.Storage_Count;
function To_Storage_Count_Access is
new Unchecked_Conversion (Address, Storage_Count_Access);
Alignment : SSE.Storage_Count)
is
begin
+ SSL.Lock_Task.all;
+
if Pool.Elmt_Size = 0 then
Vsize.Allocate (Pool, Address, Storage_Size, Alignment);
else
raise Storage_Error;
end if;
+
+ SSL.Unlock_Task.all;
+
+ exception
+ when others =>
+ SSL.Unlock_Task.all;
+ raise;
end Allocate;
----------------
Alignment : SSE.Storage_Count)
is
begin
+ SSL.Lock_Task.all;
+
if Pool.Elmt_Size = 0 then
Vsize.Deallocate (Pool, Address, Storage_Size, Alignment);
To_Storage_Count_Access (Address).all := Pool.First_Free;
Pool.First_Free := Address - Pool.The_Pool'Address + 1;
end if;
+
+ SSL.Unlock_Task.all;
+ exception
+ when others =>
+ SSL.Unlock_Task.all;
+ raise;
end Deallocate;
----------------
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
SS_Ratio_Dynamic : constant Boolean :=
Parameters.Sec_Stack_Ratio = Parameters.Dynamic;
+ -- There are two entirely different implementations of the secondary
+ -- stack mechanism in this unit, and this Boolean is used to select
+ -- between them (at compile time, so the generated code will contain
+ -- only the code for the desired variant). If SS_Ratio_Dynamic is
+ -- True, then the secondary stack is dynamically allocated from the
+ -- heap in a linked list of chunks. If SS_Ration_Dynamic is False,
+ -- then the secondary stack is allocated statically by grabbing a
+ -- section of the primary stack and using it for this purpose.
+
+ type Memory is array (Mark_Id range <>) of SSE.Storage_Element;
+ for Memory'Alignment use Standard'Maximum_Alignment;
+ -- This is the type used for actual allocation of secondary stack
+ -- areas. We require maximum alignment for all such allocations.
+
+ ---------------------------------------------------------------
+ -- Data Structures for Dynamically Allocated Secondary Stack --
+ ---------------------------------------------------------------
+
+ -- The following is a diagram of the data structures used for the
+ -- case of a dynamically allocated secondary stack, where the stack
+ -- is allocated as a linked list of chunks allocated from the heap.
-- +------------------+
-- | Next |
-- | Default_Size | | Prev |
-- +-----------------+ +------------------+
--
- --
- type Memory is array (Mark_Id range <>) of SSE.Storage_Element;
type Chunk_Id (First, Last : Mark_Id);
type Chunk_Ptr is access all Chunk_Id;
Current_Chunk : Chunk_Ptr;
end record;
+ type Stack_Ptr is access Stack_Id;
+ -- Pointer to record used to represent a dynamically allocated secondary
+ -- stack descriptor for a secondary stack chunk.
+
+ procedure Free is new Unchecked_Deallocation (Chunk_Id, Chunk_Ptr);
+ -- Free a dynamically allocated chunk
+
+ function To_Stack_Ptr is new
+ Unchecked_Conversion (Address, Stack_Ptr);
+ function To_Addr is new
+ Unchecked_Conversion (Stack_Ptr, Address);
+ -- Convert to and from address stored in task data structures
+
+ --------------------------------------------------------------
+ -- Data Structures for Statically Allocated Secondary Stack --
+ --------------------------------------------------------------
+
+ -- For the static case, the secondary stack is a single contiguous
+ -- chunk of storage, carved out of the primary stack, and represented
+ -- by the following data strcuture
+
type Fixed_Stack_Id is record
- Top : Mark_Id;
+ Top : Mark_Id;
+ -- Index of next available location in Mem. This is initialized to
+ -- 0, and then incremented on Allocate, and Decremented on Release.
+
Last : Mark_Id;
- Mem : Memory (1 .. Mark_Id'Last / 2 - 1);
- -- This should really be 1 .. Mark_Id'Last, but there is a bug in gigi
- -- with this type, introduced Sep 2001, that causes gigi to reject this
- -- type because its size in bytes overflows ???
+ -- Length of usable Mem array, which is thus the index past the
+ -- last available location in Mem. Mem (Last-1) can be used. This
+ -- is used to check that the stack does not overflow.
+
+ Max : Mark_Id;
+ -- Maximum value of Top. Initialized to 0, and then may be incremented
+ -- on Allocate, but is never Decremented. The last used location will
+ -- be Mem (Max - 1), so Max is the maximum count of used stack space.
+
+ Mem : Memory (0 .. 0);
+ -- This is the area that is actually used for the secondary stack.
+ -- Note that the upper bound is a dummy value properly defined by
+ -- the value of Last. We never actually allocate objects of type
+ -- Fixed_Stack_Id, so the bounds declared here do not matter.
end record;
- type Stack_Ptr is access Stack_Id;
- type Fixed_Stack_Ptr is access Fixed_Stack_Id;
+ Dummy_Fixed_Stack : Fixed_Stack_Id;
+ pragma Warnings (Off, Dummy_Fixed_Stack);
+ -- Well it is not quite true that we never allocate an object of the
+ -- type. This dummy object is allocated for the purpose of getting the
+ -- offset of the Mem field via the 'Position attribute (such a nuisance
+ -- that we cannot apply this to a field of a type!)
- function From_Addr is new Unchecked_Conversion (Address, Stack_Ptr);
- function To_Addr is new Unchecked_Conversion (Stack_Ptr, System.Address);
- function To_Fixed is new Unchecked_Conversion (Stack_Ptr, Fixed_Stack_Ptr);
+ type Fixed_Stack_Ptr is access Fixed_Stack_Id;
+ -- Pointer to record used to describe statically allocated sec stack
- procedure Free is new Unchecked_Deallocation (Chunk_Id, Chunk_Ptr);
+ function To_Fixed_Stack_Ptr is new
+ Unchecked_Conversion (Address, Fixed_Stack_Ptr);
+ -- Convert from address stored in task data structures
--------------
-- Allocate --
--------------
procedure SS_Allocate
- (Address : out System.Address;
+ (Addr : out Address;
Storage_Size : SSE.Storage_Count)
is
- Stack : constant Stack_Ptr :=
- From_Addr (SSL.Get_Sec_Stack_Addr.all);
- Fixed_Stack : Fixed_Stack_Ptr;
- Chunk : Chunk_Ptr;
Max_Align : constant Mark_Id := Mark_Id (Standard'Maximum_Alignment);
Max_Size : constant Mark_Id :=
((Mark_Id (Storage_Size) + Max_Align - 1) / Max_Align)
* Max_Align;
- To_Be_Released_Chunk : Chunk_Ptr;
-
begin
- -- If the secondary stack is fixed in the primary stack, then the
- -- handling becomes simple
+ -- Case of fixed allocation secondary stack
if not SS_Ratio_Dynamic then
- Fixed_Stack := To_Fixed (Stack);
+ declare
+ Fixed_Stack : constant Fixed_Stack_Ptr :=
+ To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
- if Fixed_Stack.Top + Max_Size > Fixed_Stack.Last then
- raise Storage_Error;
- end if;
+ begin
+ -- Check if max stack usage is increasing
- Address := Fixed_Stack.Mem (Fixed_Stack.Top)'Address;
- Fixed_Stack.Top := Fixed_Stack.Top + Mark_Id (Max_Size);
- return;
- end if;
+ if Fixed_Stack.Top + Max_Size > Fixed_Stack.Max then
+
+ -- If so, check if max size is exceeded
+
+ if Fixed_Stack.Top + Max_Size > Fixed_Stack.Last then
+ raise Storage_Error;
+ end if;
+
+ -- Record new max usage
+
+ Fixed_Stack.Max := Fixed_Stack.Top + Max_Size;
+ end if;
+
+ -- Set resulting address and update top of stack pointer
- Chunk := Stack.Current_Chunk;
+ Addr := Fixed_Stack.Mem (Fixed_Stack.Top)'Address;
+ Fixed_Stack.Top := Fixed_Stack.Top + Max_Size;
+ end;
- -- The Current_Chunk may not be the good one if a lot of release
- -- operations have taken place. So go down the stack if necessary
+ -- Case of dynamically allocated secondary stack
- while Chunk.First > Stack.Top loop
- Chunk := Chunk.Prev;
- end loop;
+ else
+ declare
+ Stack : constant Stack_Ptr :=
+ To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
+ Chunk : Chunk_Ptr;
- -- Find out if the available memory in the current chunk is sufficient.
- -- if not, go to the next one and eventally create the necessary room
+ To_Be_Released_Chunk : Chunk_Ptr;
- while Chunk.Last - Stack.Top + 1 < Max_Size loop
- if Chunk.Next /= null then
+ begin
+ Chunk := Stack.Current_Chunk;
- -- Release unused non-first empty chunk
+ -- The Current_Chunk may not be the good one if a lot of release
+ -- operations have taken place. So go down the stack if necessary
- if Chunk.Prev /= null and then Chunk.First = Stack.Top then
- To_Be_Released_Chunk := Chunk;
+ while Chunk.First > Stack.Top loop
Chunk := Chunk.Prev;
- Chunk.Next := To_Be_Released_Chunk.Next;
- To_Be_Released_Chunk.Next.Prev := Chunk;
- Free (To_Be_Released_Chunk);
- end if;
+ end loop;
+
+ -- Find out if the available memory in the current chunk is
+ -- sufficient, if not, go to the next one and eventally create
+ -- the necessary room.
+
+ while Chunk.Last - Stack.Top + 1 < Max_Size loop
+ if Chunk.Next /= null then
+
+ -- Release unused non-first empty chunk
+
+ if Chunk.Prev /= null and then Chunk.First = Stack.Top then
+ To_Be_Released_Chunk := Chunk;
+ Chunk := Chunk.Prev;
+ Chunk.Next := To_Be_Released_Chunk.Next;
+ To_Be_Released_Chunk.Next.Prev := Chunk;
+ Free (To_Be_Released_Chunk);
+ end if;
- -- Create new chunk of the default size unless it is not sufficient
+ -- Create new chunk of default size unless it is not
+ -- sufficient to satisfy the current request.
- elsif SSE.Storage_Count (Max_Size) <= Stack.Default_Size then
- Chunk.Next := new Chunk_Id (
- First => Chunk.Last + 1,
- Last => Chunk.Last + Mark_Id (Stack.Default_Size));
+ elsif SSE.Storage_Count (Max_Size) <= Stack.Default_Size then
+ Chunk.Next :=
+ new Chunk_Id
+ (First => Chunk.Last + 1,
+ Last => Chunk.Last + Mark_Id (Stack.Default_Size));
- Chunk.Next.Prev := Chunk;
+ Chunk.Next.Prev := Chunk;
- else
- Chunk.Next := new Chunk_Id (
- First => Chunk.Last + 1,
- Last => Chunk.Last + Max_Size);
+ -- Otherwise create new chunk of requested size
- Chunk.Next.Prev := Chunk;
- end if;
+ else
+ Chunk.Next :=
+ new Chunk_Id
+ (First => Chunk.Last + 1,
+ Last => Chunk.Last + Max_Size);
- Chunk := Chunk.Next;
- Stack.Top := Chunk.First;
- end loop;
+ Chunk.Next.Prev := Chunk;
+ end if;
- -- Resulting address is the address pointed by Stack.Top
+ Chunk := Chunk.Next;
+ Stack.Top := Chunk.First;
+ end loop;
- Address := Chunk.Mem (Stack.Top)'Address;
- Stack.Top := Stack.Top + Max_Size;
- Stack.Current_Chunk := Chunk;
+ -- Resulting address is the address pointed by Stack.Top
+
+ Addr := Chunk.Mem (Stack.Top)'Address;
+ Stack.Top := Stack.Top + Max_Size;
+ Stack.Current_Chunk := Chunk;
+ end;
+ end if;
end SS_Allocate;
-------------
-- SS_Free --
-------------
- procedure SS_Free (Stk : in out System.Address) is
- Stack : Stack_Ptr;
- Chunk : Chunk_Ptr;
-
- procedure Free is new Unchecked_Deallocation (Stack_Id, Stack_Ptr);
-
+ procedure SS_Free (Stk : in out Address) is
begin
+ -- Case of statically allocated secondary stack, nothing to free
+
if not SS_Ratio_Dynamic then
return;
- end if;
- Stack := From_Addr (Stk);
- Chunk := Stack.Current_Chunk;
+ -- Case of dynamically allocated secondary stack
+
+ else
+ declare
+ Stack : Stack_Ptr := To_Stack_Ptr (Stk);
+ Chunk : Chunk_Ptr;
- while Chunk.Prev /= null loop
- Chunk := Chunk.Prev;
- end loop;
+ procedure Free is new Unchecked_Deallocation (Stack_Id, Stack_Ptr);
- while Chunk.Next /= null loop
- Chunk := Chunk.Next;
- Free (Chunk.Prev);
- end loop;
+ begin
+ Chunk := Stack.Current_Chunk;
+
+ while Chunk.Prev /= null loop
+ Chunk := Chunk.Prev;
+ end loop;
- Free (Chunk);
- Free (Stack);
- Stk := Null_Address;
+ while Chunk.Next /= null loop
+ Chunk := Chunk.Next;
+ Free (Chunk.Prev);
+ end loop;
+
+ Free (Chunk);
+ Free (Stack);
+ Stk := Null_Address;
+ end;
+ end if;
end SS_Free;
+ ----------------
+ -- SS_Get_Max --
+ ----------------
+
+ function SS_Get_Max return Long_Long_Integer is
+ begin
+ if SS_Ratio_Dynamic then
+ return -1;
+ else
+ declare
+ Fixed_Stack : constant Fixed_Stack_Ptr :=
+ To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
+ begin
+ return Long_Long_Integer (Fixed_Stack.Max);
+ end;
+ end if;
+ end SS_Get_Max;
+
-------------
-- SS_Info --
-------------
procedure SS_Info is
- Stack : constant Stack_Ptr :=
- From_Addr (SSL.Get_Sec_Stack_Addr.all);
- Fixed_Stack : Fixed_Stack_Ptr;
- Nb_Chunks : Integer := 1;
- Chunk : Chunk_Ptr := Stack.Current_Chunk;
-
begin
Put_Line ("Secondary Stack information:");
+ -- Case of fixed secondary stack
+
if not SS_Ratio_Dynamic then
- Fixed_Stack := To_Fixed (Stack);
- Put_Line (
- " Total size : "
- & Mark_Id'Image (Fixed_Stack.Last)
- & " bytes");
- Put_Line (
- " Current allocated space : "
- & Mark_Id'Image (Fixed_Stack.Top - 1)
- & " bytes");
- return;
- end if;
+ declare
+ Fixed_Stack : constant Fixed_Stack_Ptr :=
+ To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
+
+ begin
+ Put_Line (
+ " Total size : "
+ & Mark_Id'Image (Fixed_Stack.Last)
+ & " bytes");
+
+ Put_Line (
+ " Current allocated space : "
+ & Mark_Id'Image (Fixed_Stack.Top - 1)
+ & " bytes");
+ end;
+
+ -- Case of dynamically allocated secondary stack
+
+ else
+ declare
+ Stack : constant Stack_Ptr :=
+ To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
+ Nb_Chunks : Integer := 1;
+ Chunk : Chunk_Ptr := Stack.Current_Chunk;
+
+ begin
+ while Chunk.Prev /= null loop
+ Chunk := Chunk.Prev;
+ end loop;
- while Chunk.Prev /= null loop
- Chunk := Chunk.Prev;
- end loop;
-
- while Chunk.Next /= null loop
- Nb_Chunks := Nb_Chunks + 1;
- Chunk := Chunk.Next;
- end loop;
-
- -- Current Chunk information
-
- Put_Line (
- " Total size : "
- & Mark_Id'Image (Chunk.Last)
- & " bytes");
- Put_Line (
- " Current allocated space : "
- & Mark_Id'Image (Stack.Top - 1)
- & " bytes");
-
- Put_Line (
- " Number of Chunks : "
- & Integer'Image (Nb_Chunks));
-
- Put_Line (
- " Default size of Chunks : "
- & SSE.Storage_Count'Image (Stack.Default_Size));
+ while Chunk.Next /= null loop
+ Nb_Chunks := Nb_Chunks + 1;
+ Chunk := Chunk.Next;
+ end loop;
+
+ -- Current Chunk information
+
+ Put_Line (
+ " Total size : "
+ & Mark_Id'Image (Chunk.Last)
+ & " bytes");
+
+ Put_Line (
+ " Current allocated space : "
+ & Mark_Id'Image (Stack.Top - 1)
+ & " bytes");
+
+ Put_Line (
+ " Number of Chunks : "
+ & Integer'Image (Nb_Chunks));
+
+ Put_Line (
+ " Default size of Chunks : "
+ & SSE.Storage_Count'Image (Stack.Default_Size));
+ end;
+ end if;
end SS_Info;
-------------
-------------
procedure SS_Init
- (Stk : in out System.Address;
+ (Stk : in out Address;
Size : Natural := Default_Secondary_Stack_Size)
is
- Stack : Stack_Ptr;
- Fixed_Stack : Fixed_Stack_Ptr;
-
begin
- if not SS_Ratio_Dynamic then
- Fixed_Stack := To_Fixed (From_Addr (Stk));
- Fixed_Stack.Top := Fixed_Stack.Mem'First;
-
- if Size < 2 * Mark_Id'Max_Size_In_Storage_Elements then
- Fixed_Stack.Last := 0;
- else
- Fixed_Stack.Last := Mark_Id (Size) -
- 2 * Mark_Id'Max_Size_In_Storage_Elements;
- end if;
+ -- Case of fixed size secondary stack
- return;
+ if not SS_Ratio_Dynamic then
+ declare
+ Fixed_Stack : Fixed_Stack_Ptr := To_Fixed_Stack_Ptr (Stk);
+
+ begin
+ Fixed_Stack.Top := 0;
+ Fixed_Stack.Max := 0;
+
+ if Size < Dummy_Fixed_Stack.Mem'Position then
+ Fixed_Stack.Last := 0;
+ else
+ Fixed_Stack.Last :=
+ Mark_Id (Size) - Dummy_Fixed_Stack.Mem'Position;
+ end if;
+ end;
+
+ -- Case of dynamically allocated secondary stack
+
+ else
+ declare
+ Stack : Stack_Ptr;
+ begin
+ Stack := new Stack_Id;
+ Stack.Current_Chunk := new Chunk_Id (1, Mark_Id (Size));
+ Stack.Top := 1;
+ Stack.Default_Size := SSE.Storage_Count (Size);
+ Stk := To_Addr (Stack);
+ end;
end if;
-
- Stack := new Stack_Id;
- Stack.Current_Chunk := new Chunk_Id (1, Mark_Id (Size));
- Stack.Top := 1;
- Stack.Default_Size := SSE.Storage_Count (Size);
-
- Stk := To_Addr (Stack);
end SS_Init;
-------------
function SS_Mark return Mark_Id is
begin
- return From_Addr (SSL.Get_Sec_Stack_Addr.all).Top;
+ if SS_Ratio_Dynamic then
+ return To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all).Top;
+ else
+ return To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all).Top;
+ end if;
end SS_Mark;
----------------
procedure SS_Release (M : Mark_Id) is
begin
- From_Addr (SSL.Get_Sec_Stack_Addr.all).Top := M;
+ if SS_Ratio_Dynamic then
+ To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all).Top := M;
+ else
+ To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all).Top := M;
+ end if;
end SS_Release;
-------------------------
-- Package Elaboration --
-------------------------
- -- Allocate a secondary stack for the main program to use.
+ -- Allocate a secondary stack for the main program to use
+
-- We make sure that the stack has maximum alignment. Some systems require
-- this (e.g. Sun), and in any case it is a good idea for efficiency.
Stack : aliased Stack_Id;
for Stack'Alignment use Standard'Maximum_Alignment;
- Chunk : aliased Chunk_Id (1, Default_Secondary_Stack_Size);
+ Chunk : aliased Chunk_Id (1, Mark_Id (Default_Secondary_Stack_Size));
for Chunk'Alignment use Standard'Maximum_Alignment;
- Chunk_Address : System.Address;
+ Chunk_Address : Address;
begin
if SS_Ratio_Dynamic then
Stack.Top := 1;
Stack.Current_Chunk := Chunk'Access;
- Stack.Default_Size := Default_Secondary_Stack_Size;
+ Stack.Default_Size := SSE.Storage_Offset (Default_Secondary_Stack_Size);
System.Soft_Links.Set_Sec_Stack_Addr_NT (Stack'Address);
else
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
package SSE renames System.Storage_Elements;
- Default_Secondary_Stack_Size : constant := 10 * 1024;
- -- Default size of a secondary stack
+ Default_Secondary_Stack_Size : Natural := 10 * 1024;
+ -- Default size of a secondary stack. May be modified by binder -D switch
procedure SS_Init
- (Stk : in out System.Address;
+ (Stk : in out Address;
Size : Natural := Default_Secondary_Stack_Size);
-- Initialize the secondary stack with a main stack of the given Size.
--
-- stack using System.Soft_Links.Get_Sec_Stack_Addr.
procedure SS_Allocate
- (Address : out System.Address;
+ (Addr : out Address;
Storage_Size : SSE.Storage_Count);
-- Allocate enough space for a 'Storage_Size' bytes object with Maximum
- -- alignment. The address of the allocated space is returned in 'Address'
+ -- alignment. The address of the allocated space is returned in Addr.
- procedure SS_Free (Stk : in out System.Address);
- -- Release the memory allocated for the Secondary Stack. That is to say,
- -- all the allocated chuncks.
- -- Upon return, Stk will be set to System.Null_Address
+ procedure SS_Free (Stk : in out Address);
+ -- Release the memory allocated for the Secondary Stack. That is
+ -- to say, all the allocated chunks. Upon return, Stk will be set
+ -- to System.Null_Address.
type Mark_Id is private;
-- Type used to mark the stack.
-- Restore the state of the stack corresponding to the mark M. If an
-- additional chunk have been allocated, it will never be freed during a
+ function SS_Get_Max return Long_Long_Integer;
+ -- Return maximum used space in storage units for the current secondary
+ -- stack. For a dynamically allocated secondary stack, the returned
+ -- result is always -1. For a statically allocated secondary stack,
+ -- the returned value shows the largest amount of space allocated so
+ -- far during execution of the program to the current secondary stack,
+ -- i.e. the secondary stack for the current task.
+
generic
with procedure Put_Line (S : String);
procedure SS_Info;
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Inside_Elab_Final_Code : Integer := 0;
pragma Export (C, Inside_Elab_Final_Code, "__gnat_inside_elab_final_code");
- -- ???This variable is obsolete starting from 29/08 but cannot be removed
+ -- ???This variable is obsolete since 2001-08-29 but cannot be removed
-- ???right away due to the bootstrap problems
--------------------------
-- Set_Trace --
---------------
- procedure Set_Trace
- (Flag : Character;
- Value : Boolean := True) is
+ procedure Set_Trace (Flag : Character; Value : Boolean := True) is
begin
Trace_On (Flag) := Value;
end Set_Trace;
(Self_Id : Task_ID;
Msg : String;
Flag : Character;
- Other_Id : Task_ID := null) is
+ Other_Id : Task_ID := null)
+ is
begin
if Trace_On (Flag) then
Put (To_Integer (Self_Id)'Img &
end if;
end Trace;
- procedure Write (Fd : Integer; S : String; Count : Integer) is
+ -----------
+ -- Write --
+ -----------
- Num : Integer;
+ procedure Write (Fd : Integer; S : String; Count : Integer) is
+ Discard : Integer;
+ pragma Unreferenced (Discard);
begin
- Num := System.CRTL.write (Fd, S (S'First)'Address, Count);
+ Discard := System.CRTL.write (Fd, S (S'First)'Address, Count);
+ -- Is it really right to ignore write errors here ???
end Write;
end System.Tasking.Debug;
------------
function On_X86 return Boolean is
- T : String := Sdefault.Target_Name.all;
+ T : constant String := Sdefault.Target_Name.all;
begin
-- There is no clean way to check this. That's not surprising,
procedure Expand_Limited_With_Clause (Nam : Node_Id; N : Node_Id) is
Loc : constant Source_Ptr := Sloc (Nam);
- P : Entity_Id;
Unum : Unit_Number_Type;
Withn : Node_Id;
Subunit => False,
Error_Node => Nam);
- P := Cunit_Entity (Unum);
-
if not Analyzed (Cunit (Unum)) then
Set_Library_Unit (Withn, Cunit (Unum));
Set_Corresponding_Spec
Subunit => False,
Error_Node => Nam);
- P := Cunit_Entity (Unum);
-
if not Analyzed (Cunit (Unum)) then
Set_Library_Unit (Withn, Cunit (Unum));
Set_Corresponding_Spec
-------------------------------
procedure Install_Limited_Withed_Unit (N : Node_Id) is
- Unum : Unit_Number_Type :=
+ Unum : constant Unit_Number_Type :=
Get_Source_Unit (Library_Unit (N));
- P_Unit : Entity_Id := Unit (Library_Unit (N));
+ P_Unit : constant Entity_Id := Unit (Library_Unit (N));
P : Entity_Id;
Lim_Elmt : Elmt_Id;
Lim_Typ : Entity_Id;
-------------------------
procedure Build_Limited_Views (N : Node_Id) is
-
- Unum : Unit_Number_Type := Get_Source_Unit (Library_Unit (N));
- P : Entity_Id := Cunit_Entity (Unum);
+ Unum : constant Unit_Number_Type := Get_Source_Unit (Library_Unit (N));
+ P : constant Entity_Id := Cunit_Entity (Unum);
Spec : Node_Id; -- To denote a package specification
Lim_Typ : Entity_Id; -- To denote shadow entities.
-- Could use more comments below ???
procedure Build_Chain (Spec : Node_Id; Scope : Entity_Id) is
- Decl : Node_Id;
- Analyzed_Unit : Boolean := Analyzed (Cunit (Unum));
+ Analyzed_Unit : constant Boolean := Analyzed (Cunit (Unum));
Is_Tagged : Boolean;
+ Decl : Node_Id;
begin
Decl := First (Visible_Declarations (Spec));
-- Local package
declare
- Spec : Node_Id := Specification (Decl);
+ Spec : constant Node_Id := Specification (Decl);
begin
Comp_Typ := Defining_Unit_Name (Spec);
--------------------------------
procedure Remove_Limited_With_Clause (N : Node_Id) is
- P_Unit : Entity_Id := Unit (Library_Unit (N));
+ P_Unit : constant Entity_Id := Unit (Library_Unit (N));
P : Entity_Id := Defining_Unit_Name (Specification (P_Unit));
Lim_Elmt : Elmt_Id;
Lim_Typ : Entity_Id;
if In_Open_Scopes (Scope (Scope (Gen_Unit))) then
declare
- Decl : Node_Id :=
+ Decl : constant Node_Id :=
Original_Node
(Unit_Declaration_Node (Scope (Gen_Unit)));
begin
Gen_Anc : Entity_Id)
return Boolean
is
- Gen_Par : Entity_Id := Generic_Parent (Act_Spec);
+ Gen_Par : constant Entity_Id := Generic_Parent (Act_Spec);
begin
if No (Gen_Par) then
begin
Decl := First (Actual_Decls);
-
- while (Present (Decl)) loop
+ while Present (Decl) loop
if Nkind (Decl) = N_Subtype_Declaration
and then Chars (Defining_Identifier (Decl)) =
Chars (Etype (A_Gen_T))
-- a more informative message.
function Try_Indexed_Call
- (N : Node_Id;
- Nam : Entity_Id;
- Typ : Entity_Id)
- return Boolean;
+ (N : Node_Id;
+ Nam : Entity_Id;
+ Typ : Entity_Id) return Boolean;
-- If a function has defaults for all its actuals, a call to it may
-- in fact be an indexing on the result of the call. Try_Indexed_Call
-- attempts the interpretation as an indexing, prior to analysis as
-- interpretations (same symbol but two different types).
function Try_Indirect_Call
- (N : Node_Id;
- Nam : Entity_Id;
- Typ : Entity_Id)
- return Boolean;
+ (N : Node_Id;
+ Nam : Entity_Id;
+ Typ : Entity_Id) return Boolean;
-- Similarly, a function F that needs no actuals can return an access
-- to a subprogram, and the call F (X) interpreted as F.all (X). In
-- this case the call may be overloaded with both interpretations.
Check_Fully_Declared (Type_Id, N);
Set_Directly_Designated_Type (Acc_Type, Type_Id);
- if Is_Protected_Type (Type_Id) then
- Check_Restriction (No_Protected_Type_Allocators, N);
- end if;
-
if Is_Limited_Type (Type_Id)
and then Comes_From_Source (N)
and then not In_Instance_Body
Set_Directly_Designated_Type (Acc_Type, Type_Id);
Check_Fully_Declared (Type_Id, N);
+ -- Check restriction against dynamically allocated protected
+ -- objects. Note that when limited aggregates are supported,
+ -- a similar test should be applied to an allocator with a
+ -- qualified expression ???
+
+ if Is_Protected_Type (Type_Id) then
+ Check_Restriction (No_Protected_Type_Allocators, N);
+ end if;
+
-- Check for missing initialization. Skip this check if we already
-- had errors on analyzing the allocator, since in that case these
-- are probably cascaded errors
-----------------------
function Try_Indirect_Call
- (N : Node_Id;
- Nam : Entity_Id;
- Typ : Entity_Id)
- return Boolean
+ (N : Node_Id;
+ Nam : Entity_Id;
+ Typ : Entity_Id) return Boolean
is
Actuals : constant List_Id := Parameter_Associations (N);
Actual : Node_Id;
----------------------
function Try_Indexed_Call
- (N : Node_Id;
- Nam : Entity_Id;
- Typ : Entity_Id)
- return Boolean
+ (N : Node_Id;
+ Nam : Entity_Id;
+ Typ : Entity_Id) return Boolean
is
Actuals : constant List_Id := Parameter_Associations (N);
Actual : Node_Id;
and then Serious_Errors_Detected = 0
then
declare
- Chosen : Node_Id := Find_Static_Alternative (N);
+ Chosen : constant Node_Id := Find_Static_Alternative (N);
Alt : Node_Id;
begin
--------------------------------
procedure Generate_Parent_References is
- Decl : Node_Id := Parent (N);
+ Decl : constant Node_Id := Parent (N);
begin
if Id = Cunit_Entity (Main_Unit)
-- --
-- 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- --
-- There is no need for elaboration checks on the new entity, which
-- may be called before the next freezing point where the body will
- -- appear.
+ -- appear. Elaboration checks refer to the real entity, not the one
+ -- created by the renaming declaration.
Set_Kill_Elaboration_Checks (New_S, True);
-- --
-- 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- --
Decl : Node_Id;
E_Scope : Entity_Id;
- -- Top level scope of entity for called subprogram
+ -- Top level scope of entity for called subprogram. This
+ -- value includes following renamings and derivations, so
+ -- this scope can be in a non-visible unit. This is the
+ -- scope that is to be investigated to see whether an
+ -- elaboration check is required.
+
+ W_Scope : Entity_Id;
+ -- Top level scope of directly called entity for subprogram.
+ -- This differs from E_Scope in the case where renamings or
+ -- derivations are involved, since it does not follow these
+ -- links, thus W_Scope is always in a visible unit. This is
+ -- the scope for the Elaborate_All if one is needed.
Body_Acts_As_Spec : Boolean;
-- Set to true if call is to body acting as spec (no separate spec)
Ent := Alias (Ent);
E_Scope := Ent;
- -- If no alias, there is a previous error.
+ -- If no alias, there is a previous error
if No (Ent) then
return;
return;
end if;
+ -- Find top level scope for called entity (not following renamings
+ -- or derivations). This is where the Elaborate_All will go if it
+ -- is needed. We start with the called entity, except in the case
+ -- of initialization procedures, where the init proc is in the root
+ -- package, where we start fromn the entity of the name in the call.
+
+ if Is_Entity_Name (Name (N))
+ and then Is_Init_Proc (Entity (Name (N)))
+ then
+ W_Scope := Scope (Entity (Name (N)));
+ else
+ W_Scope := E;
+ end if;
+
+ while not Is_Compilation_Unit (W_Scope) loop
+ W_Scope := Scope (W_Scope);
+ end loop;
+
+ -- Now check if an elaborate_all (or dynamic check) is needed
+
if not Suppress_Elaboration_Warnings (Ent)
and then not Elaboration_Checks_Suppressed (Ent)
and then not Suppress_Elaboration_Warnings (E_Scope)
if Inst_Case then
Error_Msg_NE
("instantiation of& may raise Program_Error?", N, Ent);
+
else
if Is_Init_Proc (Entity (Name (N)))
and then Comes_From_Source (Ent)
then
Error_Msg_NE
- ("implicit call to & in initialization" &
- " may raise Program_Error?", N, Ent);
- E_Scope := Scope (Entity (Name (N)));
+ ("implicit call to & may raise Program_Error?", N, Ent);
else
Error_Msg_NE
("call to & may raise Program_Error?", N, Ent);
end if;
-
- if Unit_Callee = No_Unit
- and then E_Scope = Current_Scope
- then
- -- The missing pragma cannot be on the current unit, so
- -- place it on the compilation unit that contains the
- -- called entity, which is more likely to be right.
-
- E_Scope := Ent;
-
- while not Is_Compilation_Unit (E_Scope) loop
- E_Scope := Scope (E_Scope);
- end loop;
- end if;
end if;
Error_Msg_Qual_Level := Nat'Last;
Error_Msg_NE
- ("\missing pragma Elaborate_All for&?", N, E_Scope);
+ ("\missing pragma Elaborate_All for&?", N, W_Scope);
Error_Msg_Qual_Level := 0;
Output_Calls (N);
-- unless in All_Errors_Mode.
if not All_Errors_Mode and not Dynamic_Elaboration_Checks then
- Set_Suppress_Elaboration_Warnings (E_Scope, True);
+ Set_Suppress_Elaboration_Warnings (W_Scope, True);
end if;
end if;
if Dynamic_Elaboration_Checks then
if not Elaboration_Checks_Suppressed (Ent)
+ and then not Elaboration_Checks_Suppressed (W_Scope)
and then not Elaboration_Checks_Suppressed (E_Scope)
and then not Cunit_SC
then
-- Runtime elaboration check required. Generate check of the
-- elaboration Boolean for the unit containing the entity.
+ -- Note that for this case, we do check the real unit (the
+ -- one from following renamings, since that is the issue!)
+
+ -- Could this possibly miss a useless but required PE???
+
Insert_Elab_Check (N,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Elaborated,
(Spec_Entity (E_Scope), Loc)));
end if;
- -- If no dynamic check required, then ask binder to guarantee
- -- that the necessary elaborations will be done properly!
+ -- Case of static elaboration model
else
- if not Suppress_Elaboration_Warnings (E)
- and then not Elaboration_Checks_Suppressed (E)
- and then not Suppress_Elaboration_Warnings (E_Scope)
- and then not Elaboration_Checks_Suppressed (E_Scope)
- and then Elab_Warnings
- and then Generate_Warnings
- and then not Inst_Case
+ -- Do not do anything if elaboration checks suppressed. Note
+ -- that we check Ent here, not E, since we want the real entity
+ -- for the body to see if checks are suppressed for it, not the
+ -- dummy entry for renamings or derivations.
+
+ if Elaboration_Checks_Suppressed (Ent)
+ or else Elaboration_Checks_Suppressed (E_Scope)
+ or else Elaboration_Checks_Suppressed (W_Scope)
then
- Error_Msg_Node_2 := E_Scope;
- Error_Msg_NE ("call to& in elaboration code " &
- "requires pragma Elaborate_All on&?", N, E);
- end if;
+ null;
+
+ -- Here we need to generate an implicit elaborate all
+
+ else
+ -- Generate elaborate_all warning unless suppressed
- Set_Elaborate_All_Desirable (E_Scope);
- Set_Suppress_Elaboration_Warnings (E_Scope, True);
+ if (Elab_Warnings and Generate_Warnings and not Inst_Case)
+ and then not Suppress_Elaboration_Warnings (Ent)
+ and then not Suppress_Elaboration_Warnings (E_Scope)
+ and then not Suppress_Elaboration_Warnings (W_Scope)
+ then
+ Error_Msg_Node_2 := W_Scope;
+ Error_Msg_NE
+ ("call to& in elaboration code " &
+ "requires pragma Elaborate_All on&?", N, E);
+ end if;
+
+ -- Set indication for binder to generate Elaborate_All
+
+ Set_Elaborate_All_Desirable (W_Scope);
+ Set_Suppress_Elaboration_Warnings (W_Scope, True);
+ end if;
end if;
-- Case of entity is in same unit as call or instantiation
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
+with Table;
with Uintp; use Uintp;
with GNAT.HTable; use GNAT.HTable;
Homonym : Access_Elim_Data;
-- Pointer to next entry with same key
+ Prag : Node_Id;
+ -- Node_Id for Eliminate pragma
+
end record;
----------------
end Set_Next;
end Hash_Subprograms;
+ ------------
+ -- Tables --
+ ------------
+
+ -- The following table records the data for each pragmas, using the
+ -- entity name as the hash key for retrieval. Entries in this table
+ -- are set by Process_Eliminate_Pragma and read by Check_Eliminated.
+
package Elim_Hash_Table is new Static_HTable (
Header_Num => Header_Num,
Element => Element,
Hash => Hash_Subprograms.Hash,
Equal => Hash_Subprograms.Equal);
+ -- The following table records entities for subprograms that are
+ -- eliminated, and corresponding eliminate pragmas that caused the
+ -- elimination. Entries in this table are set by Check_Eliminated
+ -- and read by Eliminate_Error_Msg.
+
+ type Elim_Entity_Entry is record
+ Prag : Node_Id;
+ Subp : Entity_Id;
+ end record;
+
+ package Elim_Entities is new Table.Table (
+ Table_Component_Type => Elim_Entity_Entry,
+ Table_Index_Type => Name_Id,
+ Table_Low_Bound => First_Name_Id,
+ Table_Initial => 50,
+ Table_Increment => 200,
+ Table_Name => "Elim_Entries");
+
----------------------
-- Check_Eliminated --
----------------------
if No_Elimination then
return;
- -- Elimination of objects and types is not implemented yet.
+ -- Elimination of objects and types is not implemented yet
elsif Ekind (E) not in Subprogram_Kind then
return;
-- Loop through homonyms for this key
while Elmt /= null loop
+ declare
+ procedure Set_Eliminated;
+ -- Set current subprogram entity as eliminated
- -- First we check that the name of the entity matches
+ procedure Set_Eliminated is
+ begin
+ Set_Is_Eliminated (E);
+ Elim_Entities.Append ((Prag => Elmt.Prag, Subp => E));
+ end Set_Eliminated;
- if Elmt.Entity_Name /= Chars (E) then
- goto Continue;
- end if;
+ begin
+ -- First we check that the name of the entity matches
+
+ if Elmt.Entity_Name /= Chars (E) then
+ goto Continue;
+ end if;
+
+ -- Then we need to see if the static scope matches within the
+ -- compilation unit.
- -- Then we need to see if the static scope matches within the
- -- compilation unit.
+ Scop := Scope (E);
+ if Elmt.Entity_Scope /= null then
+ for J in reverse Elmt.Entity_Scope'Range loop
+ if Elmt.Entity_Scope (J) /= Chars (Scop) then
+ goto Continue;
+ end if;
- Scop := Scope (E);
- if Elmt.Entity_Scope /= null then
- for J in reverse Elmt.Entity_Scope'Range loop
- if Elmt.Entity_Scope (J) /= Chars (Scop) then
+ Scop := Scope (Scop);
+
+ if not Is_Compilation_Unit (Scop) and then J = 1 then
+ goto Continue;
+ end if;
+ end loop;
+ end if;
+
+ -- Now see if compilation unit matches
+
+ for J in reverse Elmt.Unit_Name'Range loop
+ if Elmt.Unit_Name (J) /= Chars (Scop) then
goto Continue;
end if;
Scop := Scope (Scop);
- if not Is_Compilation_Unit (Scop) and then J = 1 then
+ if Scop /= Standard_Standard and then J = 1 then
goto Continue;
end if;
end loop;
- end if;
-
- -- Now see if compilation unit matches
-
- for J in reverse Elmt.Unit_Name'Range loop
- if Elmt.Unit_Name (J) /= Chars (Scop) then
- goto Continue;
- end if;
-
- Scop := Scope (Scop);
- if Scop /= Standard_Standard and then J = 1 then
+ if Scop /= Standard_Standard then
goto Continue;
end if;
- end loop;
-
- if Scop /= Standard_Standard then
- goto Continue;
- end if;
-
- -- Check for case of given entity is a library level subprogram
- -- and we have the single parameter Eliminate case, a match!
-
- if Is_Compilation_Unit (E)
- and then Is_Subprogram (E)
- and then No (Elmt.Entity_Node)
- then
- Set_Is_Eliminated (E);
- return;
-
- -- Check for case of type or object with two parameter case
- elsif (Is_Type (E) or else Is_Object (E))
- and then Elmt.Result_Type = No_Name
- and then Elmt.Parameter_Types = null
- then
- Set_Is_Eliminated (E);
- return;
-
- -- Check for case of subprogram
-
- elsif Ekind (E) = E_Function
- or else Ekind (E) = E_Procedure
- then
- -- If Homonym_Number present, then see if it matches
-
- if Elmt.Homonym_Number /= No_Uint then
- Ctr := 1;
-
- Ent := E;
- while Present (Homonym (Ent))
- and then Scope (Ent) = Scope (Homonym (Ent))
- loop
- Ctr := Ctr + 1;
- Ent := Homonym (Ent);
- end loop;
+ -- Check for case of given entity is a library level subprogram
+ -- and we have the single parameter Eliminate case, a match!
+
+ if Is_Compilation_Unit (E)
+ and then Is_Subprogram (E)
+ and then No (Elmt.Entity_Node)
+ then
+ Set_Eliminated;
+ return;
+
+ -- Check for case of type or object with two parameter case
+
+ elsif (Is_Type (E) or else Is_Object (E))
+ and then Elmt.Result_Type = No_Name
+ and then Elmt.Parameter_Types = null
+ then
+ Set_Eliminated;
+ return;
+
+ -- Check for case of subprogram
+
+ elsif Ekind (E) = E_Function
+ or else Ekind (E) = E_Procedure
+ then
+ -- If Homonym_Number present, then see if it matches
+
+ if Elmt.Homonym_Number /= No_Uint then
+ Ctr := 1;
+
+ Ent := E;
+ while Present (Homonym (Ent))
+ and then Scope (Ent) = Scope (Homonym (Ent))
+ loop
+ Ctr := Ctr + 1;
+ Ent := Homonym (Ent);
+ end loop;
- if Ctr /= Elmt.Homonym_Number then
- goto Continue;
+ if Ctr /= Elmt.Homonym_Number then
+ goto Continue;
+ end if;
end if;
- end if;
- -- If we have a Result_Type, then we must have a function
- -- with the proper result type
+ -- If we have a Result_Type, then we must have a function
+ -- with the proper result type
- if Elmt.Result_Type /= No_Name then
- if Ekind (E) /= E_Function
- or else Chars (Etype (E)) /= Elmt.Result_Type
- then
- goto Continue;
+ if Elmt.Result_Type /= No_Name then
+ if Ekind (E) /= E_Function
+ or else Chars (Etype (E)) /= Elmt.Result_Type
+ then
+ goto Continue;
+ end if;
end if;
- end if;
- -- If we have Parameter_Types, they must match
+ -- If we have Parameter_Types, they must match
- if Elmt.Parameter_Types /= null then
- Form := First_Formal (E);
+ if Elmt.Parameter_Types /= null then
+ Form := First_Formal (E);
- if No (Form) and then Elmt.Parameter_Types = null then
- null;
+ if No (Form) and then Elmt.Parameter_Types = null then
+ null;
- elsif Elmt.Parameter_Types = null then
- goto Continue;
+ elsif Elmt.Parameter_Types = null then
+ goto Continue;
- else
- for J in Elmt.Parameter_Types'Range loop
- if No (Form)
- or else Chars (Etype (Form)) /= Elmt.Parameter_Types (J)
- then
+ else
+ for J in Elmt.Parameter_Types'Range loop
+ if No (Form)
+ or else
+ Chars (Etype (Form)) /= Elmt.Parameter_Types (J)
+ then
+ goto Continue;
+ else
+ Next_Formal (Form);
+ end if;
+ end loop;
+
+ if Present (Form) then
goto Continue;
- else
- Next_Formal (Form);
end if;
- end loop;
-
- if Present (Form) then
- goto Continue;
end if;
end if;
- end if;
- -- If we fall through, this is match
+ -- If we fall through, this is match
- Set_Is_Eliminated (E);
- return;
- end if;
+ Set_Eliminated;
+ return;
+ end if;
- <<Continue>> Elmt := Elmt.Homonym;
+ <<Continue>> Elmt := Elmt.Homonym;
+ end;
end loop;
return;
end Check_Eliminated;
+ -------------------------
+ -- Eliminate_Error_Msg --
+ -------------------------
+
+ procedure Eliminate_Error_Msg (N : Node_Id; E : Entity_Id) is
+ begin
+ for J in Elim_Entities.First .. Elim_Entities.Last loop
+ if E = Elim_Entities.Table (J).Subp then
+ Error_Msg_Sloc := Sloc (Elim_Entities.Table (J).Prag);
+ Error_Msg_NE ("cannot call subprogram & eliminated #", N, E);
+ return;
+ end if;
+ end loop;
+
+ -- Should never fall through, since entry should be in table
+
+ pragma Assert (False);
+ end Eliminate_Error_Msg;
+
----------------
-- Initialize --
----------------
procedure Initialize is
begin
Elim_Hash_Table.Reset;
+ Elim_Entities.Init;
No_Elimination := True;
end Initialize;
------------------------------
procedure Process_Eliminate_Pragma
- (Arg_Unit_Name : Node_Id;
+ (Pragma_Node : Node_Id;
+ Arg_Unit_Name : Node_Id;
Arg_Entity : Node_Id;
Arg_Parameter_Types : Node_Id;
Arg_Result_Type : Node_Id;
-- Start of processing for Process_Eliminate_Pragma
begin
+ Data.Prag := Pragma_Node;
Error_Msg_Name_1 := Name_Eliminate;
-- Process Unit_Name argument
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- Initialize for new main souce program
procedure Process_Eliminate_Pragma
- (Arg_Unit_Name : Node_Id;
+ (Pragma_Node : Node_Id;
+ Arg_Unit_Name : Node_Id;
Arg_Entity : Node_Id;
Arg_Parameter_Types : Node_Id;
Arg_Result_Type : Node_Id;
Arg_Homonym_Number : Node_Id);
- -- Process eliminate pragma. The number of arguments has been checked,
- -- as well as possible optional identifiers, but no other checks have
- -- been made. This subprogram completes the checking, and then if the
- -- pragma is well formed, makes appropriate entries in the internal
- -- tables used to keep track of Eliminate pragmas. The five arguments
- -- are expressions (not pragma argument associations) for the possible
- -- pragma arguments. A parameter that is not present is set to Empty.
+ -- Process eliminate pragma (given by Pragma_Node). The number of
+ -- arguments has been checked, as well as possible optional identifiers,
+ -- but no other checks have been made. This subprogram completes the
+ -- checking, and then if the pragma is well formed, makes appropriate
+ -- entries in the internal tables used to keep track of Eliminate pragmas.
+ -- The other five arguments are expressions (rather than pragma argument
+ -- associations) for the possible pragma arguments. A parameter that
+ -- is not present is set to Empty.
procedure Check_Eliminated (E : Entity_Id);
-- Checks if entity E is eliminated, and if so sets the Is_Eliminated
-- flag on the given entity.
+ procedure Eliminate_Error_Msg (N : Node_Id; E : Entity_Id);
+ -- Called by the back end on encouterning a call to an eliminated
+ -- subprogram. N is the node for the call, and E is the entity of
+ -- the subprogram being eliminated.
+
+
+
end Sem_Elim;
-------------------------
procedure Eval_String_Literal (N : Node_Id) is
- T : constant Entity_Id := Etype (N);
- B : constant Entity_Id := Base_Type (T);
- I : Entity_Id;
+ Typ : constant Entity_Id := Etype (N);
+ Bas : constant Entity_Id := Base_Type (Typ);
+ Xtp : Entity_Id;
+ Len : Nat;
+ Lo : Node_Id;
begin
-- Nothing to do if error type (handles cases like default expressions
-- or generics where we have not yet fully resolved the type)
- if B = Any_Type or else B = Any_String then
+ if Bas = Any_Type or else Bas = Any_String then
return;
+ end if;
-- String literals are static if the subtype is static (RM 4.9(2)), so
-- reset the static expression flag (it was set unconditionally in
-- Analyze_String_Literal) if the subtype is non-static. We tell if
-- the subtype is static by looking at the lower bound.
- elsif not Is_OK_Static_Expression (String_Literal_Low_Bound (T)) then
+ if Ekind (Typ) = E_String_Literal_Subtype then
+ if not Is_OK_Static_Expression (String_Literal_Low_Bound (Typ)) then
+ Set_Is_Static_Expression (N, False);
+ return;
+ end if;
+
+ -- Here if Etype of string literal is normal Etype (not yet possible,
+ -- but may be possible in future!)
+
+ elsif not Is_OK_Static_Expression
+ (Type_Low_Bound (Etype (First_Index (Typ))))
+ then
Set_Is_Static_Expression (N, False);
+ return;
+ end if;
+
+ -- If original node was a type conversion, then result if non-static
- elsif Nkind (Original_Node (N)) = N_Type_Conversion then
+ if Nkind (Original_Node (N)) = N_Type_Conversion then
Set_Is_Static_Expression (N, False);
+ return;
+ end if;
-- Test for illegal Ada 95 cases. A string literal is illegal in
-- Ada 95 if its bounds are outside the index base type and this
- -- index type is static. This can hapen in only two ways. Either
+ -- index type is static. This can happen in only two ways. Either
-- the string literal is too long, or it is null, and the lower
-- bound is type'First. In either case it is the upper bound that
-- is out of range of the index type.
- elsif Ada_95 then
- if Root_Type (B) = Standard_String
- or else Root_Type (B) = Standard_Wide_String
+ if Ada_95 then
+ if Root_Type (Bas) = Standard_String
+ or else
+ Root_Type (Bas) = Standard_Wide_String
then
- I := Standard_Positive;
+ Xtp := Standard_Positive;
else
- I := Etype (First_Index (B));
+ Xtp := Etype (First_Index (Bas));
end if;
- if String_Literal_Length (T) > String_Type_Len (B) then
+ if Ekind (Typ) = E_String_Literal_Subtype then
+ Lo := String_Literal_Low_Bound (Typ);
+ else
+ Lo := Type_Low_Bound (Etype (First_Index (Typ)));
+ end if;
+
+ Len := String_Length (Strval (N));
+
+ if UI_From_Int (Len) > String_Type_Len (Bas) then
Apply_Compile_Time_Constraint_Error
(N, "string literal too long for}", CE_Length_Check_Failed,
- Ent => B,
- Typ => First_Subtype (B));
+ Ent => Bas,
+ Typ => First_Subtype (Bas));
- elsif String_Literal_Length (T) = 0
- and then not Is_Generic_Type (I)
- and then Expr_Value (String_Literal_Low_Bound (T)) =
- Expr_Value (Type_Low_Bound (Base_Type (I)))
+ elsif Len = 0
+ and then not Is_Generic_Type (Xtp)
+ and then
+ Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp)))
then
Apply_Compile_Time_Constraint_Error
(N, "null string literal not allowed for}",
CE_Length_Check_Failed,
- Ent => B,
- Typ => First_Subtype (B));
+ Ent => Bas,
+ Typ => First_Subtype (Bas));
end if;
end if;
-
end Eval_String_Literal;
--------------------------
-- --
-- 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- --
declare
Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
+
begin
if Present (Decl)
and then Nkind (Decl) = N_Subprogram_Declaration
----------------------------
function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean is
- Decl : Node_Id := Unit_Declaration_Node (Subp);
+ Decl : constant Node_Id := Unit_Declaration_Node (Subp);
begin
if Nkind (Decl) = N_Subprogram_Body then
if Expander_Active then
declare
- Temp : Node_Id := New_Copy_Tree (Expression (Arg2));
+ Temp : constant Node_Id :=
+ New_Copy_Tree (Expression (Arg2));
begin
Set_Parent (Temp, N);
Pre_Analyze_And_Resolve (Temp, RTE (RE_Interrupt_ID));
end if;
Process_Eliminate_Pragma
- (Unit_Name,
+ (N,
+ Unit_Name,
Entity,
Parameter_Types,
Result_Type,
No_Run_Time_Mode := True;
Configurable_Run_Time_Mode := True;
- if Ttypes.System_Word_Size = 32 then
- Duration_32_Bits_On_Target := True;
- end if;
+ declare
+ Word32 : constant Boolean := Ttypes.System_Word_Size = 32;
+ begin
+ if Word32 then
+ Duration_32_Bits_On_Target := True;
+ end if;
+ end;
Restrictions (No_Finalization) := True;
Restrictions (No_Exception_Handlers) := True;
-- than appearence as any argument is insignificant, a positive value
-- indicates that appearence in that parameter position is significant.
- Sig_Flags : array (Pragma_Id) of Int :=
+ Sig_Flags : constant array (Pragma_Id) of Int :=
(Pragma_AST_Entry => -1,
Pragma_Abort_Defer => -1,
Pragma_Ada_83 => -1,
-- --
-- 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- --
-- doesn't think of them this way!)
if Typ = Standard_Void_Type then
- Error_Msg_N ("expect procedure name in procedure call", N);
+
+ -- Special case message if function used as a procedure
+
+ if Nkind (N) = N_Procedure_Call_Statement
+ and then Is_Entity_Name (Name (N))
+ and then Ekind (Entity (Name (N))) = E_Function
+ then
+ Error_Msg_NE
+ ("cannot use function & in a procedure call",
+ Name (N), Entity (Name (N)));
+
+ -- Otherwise give general message (not clear what cases
+ -- this covers, but no harm in providing for them!)
+
+ else
+ Error_Msg_N ("expect procedure name in procedure call", N);
+ end if;
+
Found := True;
-- Otherwise we do have a subexpression with the wrong type
Subtype_Id := Create_Itype (E_String_Literal_Subtype, N);
end if;
- Set_String_Literal_Length (Subtype_Id,
- UI_From_Int (String_Length (Strval (N))));
- Set_Etype (Subtype_Id, Base_Type (Typ));
- Set_Is_Constrained (Subtype_Id);
+ Set_String_Literal_Length (Subtype_Id, UI_From_Int
+ (String_Length (Strval (N))));
+ Set_Etype (Subtype_Id, Base_Type (Typ));
+ Set_Is_Constrained (Subtype_Id);
-- The low bound is set from the low bound of the corresponding
-- index type. Note that we do not store the high bound in the
-- specified check suppressed (can be All_Checks to suppress all checks).
procedure Resolve (N : Node_Id);
- pragma Inline (Resolve);
-- A version of Resolve where the type to be used for resolution is
-- taken from the Etype (N). This is commonly used in cases where the
-- context does not add anything and the first pass of analysis found
-- Same, but use type of node because context does not impose a single
-- type.
+private
+ procedure Resolve_Implicit_Type (N : Node_Id) renames Resolve;
+ pragma Inline (Resolve_Implicit_Type);
+ -- We use this renaming to make the application of Inline very explicit
+ -- to this version, since other versions of Resolve are not inlined.
+
end Sem_Res;
function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
Loc : constant Source_Ptr := Sloc (Typ);
+ Constraints : constant List_Id := New_List;
+ Components : constant Elist_Id := New_Elmt_List;
Comp_Elmt : Elmt_Id;
Comp_Id : Node_Id;
Comp_List : Node_Id;
Discr : Entity_Id;
Discr_Val : Node_Id;
- Constraints : List_Id := New_List;
- Components : Elist_Id := New_Elmt_List;
Report_Errors : Boolean;
begin
-----------------------
function Type_Access_Level (Typ : Entity_Id) return Uint is
- Btyp : Entity_Id := Base_Type (Typ);
+ Btyp : Entity_Id;
begin
-- If the type is an anonymous access type we treat it as being
-- declared at the library level to ensure that names such as
-- X.all'access don't fail static accessibility checks.
+ Btyp := Base_Type (Typ);
if Ekind (Btyp) in Access_Kind then
if Ekind (Btyp) = E_Anonymous_Access_Type then
return Scope_Depth (Standard_Standard);
procedure Process_End_Label
(N : Node_Id;
Typ : Character;
- Ent : Entity_Id);
+ Ent : Entity_Id);
-- N is a node whose End_Label is to be processed, generating all
-- appropriate cross-reference entries, and performing style checks
-- for any identifier references in the end label. Typ is either
-- Is_Public based upon the new scope.
function Type_Access_Level (Typ : Entity_Id) return Uint;
- -- Return the accessibility level of Typ.
+ -- Return the accessibility level of Typ
function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id;
-- Unit_Id is the simple name of a program unit, this function returns
-- with a lower precedence than the operator (or equal precedence if
-- appearing as the right operand), then parentheses are required.
- Op_Prec : array (N_Subexpr) of Short_Short_Integer :=
+ Op_Prec : constant array (N_Subexpr) of Short_Short_Integer :=
(N_Op_And => 1,
N_Op_Or => 1,
N_Op_Xor => 1,
-- --
------------------------------------------------------------------------------
-with Debug; use Debug;
-with Osint; use Osint;
-with Opt; use Opt;
+with Debug; use Debug;
+with Osint; use Osint;
+with Opt; use Opt;
with System.WCh_Con; use System.WCh_Con;
then
Osint.Fail ("invalid switch: """, Switch_Chars, """"
& " (gnat not needed here)");
-
end if;
-- Loop to scan through switches given in switch string
return;
+ -- Processing for D switch
+
+ when 'D' =>
+ Ptr := Ptr + 1;
+ Scan_Pos (Switch_Chars, Max, Ptr, Default_Sec_Stack_Size);
+
-- Processing for e switch
when 'e' =>
when 'g' =>
Ptr := Ptr + 1;
- GNAT_Mode := True;
- Identifier_Character_Set := 'n';
- Warning_Mode := Treat_As_Error;
- Check_Unreferenced := True;
- Check_Withs := True;
- Check_Unreferenced_Formals := True;
- System_Extend_Unit := Empty;
+ GNAT_Mode := True;
+ Identifier_Character_Set := 'n';
+ System_Extend_Unit := Empty;
+ Warning_Mode := Treat_As_Error;
+
+ -- Set default warnings (basically -gnatwa)
+
+ Check_Unreferenced := True;
+ Check_Unreferenced_Formals := True;
+ Check_Withs := True;
+ Constant_Condition_Warnings := True;
+ Implementation_Unit_Warnings := True;
+ Ineffective_Inline_Warnings := True;
+ Warn_On_Constant := True;
+ Warn_On_Export_Import := True;
+ Warn_On_Modified_Unread := True;
+ Warn_On_No_Value_Assigned := True;
+ Warn_On_Obsolescent_Feature := True;
+ Warn_On_Redundant_Constructs := True;
+ Warn_On_Unchecked_Conversion := True;
+ Warn_On_Unrecognized_Pragma := True;
Set_Default_Style_Check_Options;
Bind_Only := True;
Make_Steps := True;
+ -- Processing for B switch
+
+ when 'B' =>
+ Ptr := Ptr + 1;
+ Build_Bind_And_Link_Full_Project := True;
+
-- Processing for c switch
when 'c' =>
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2003, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2004, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
tree gnu_obj_size;
int align;
+ /* If this is a thin pointer, we must dereference it to create
+ a fat pointer, then go back below to a thin pointer. The
+ reason for this is that we need a fat pointer someplace in
+ order to properly compute the size. */
+ if (TYPE_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
+ gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE,
+ build_unary_op (INDIRECT_REF, NULL_TREE,
+ gnu_ptr));
+
/* If this is an unconstrained array, we know the object must
have been allocated with the template in front of the object.
So pass the template address, but get the total size. Do this
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
+with Gnatvsn;
with Hostparm;
with Osint; use Osint;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
-with Gnatvsn;
-
package body VMS_Conv is
Param_Count : Natural := 0;
function Matching_Name
(S : String;
Itm : Item_Ptr;
- Quiet : Boolean := False)
- return Item_Ptr;
+ Quiet : Boolean := False) return Item_Ptr;
-- Determines if the item list headed by Itm and threaded through the
-- Next fields (with null marking the end of the list), contains an
-- entry that uniquely matches the given string. The match is case
function Matching_Name
(S : String;
Itm : Item_Ptr;
- Quiet : Boolean := False)
- return Item_Ptr
+ Quiet : Boolean := False) return Item_Ptr
is
P1, P2 : Item_Ptr;
begin
Put ("GNAT ");
Put (Gnatvsn.Gnat_Version_String);
- Put_Line (" Copyright 1996-2003 Free Software Foundation, Inc.");
+ Put_Line (" Copyright 1996-2004 Free Software Foundation, Inc.");
end Output_Version;
-----------
function Get_Arg_End
(Argv : String;
- Arg_Idx : Integer)
- return Integer;
+ Arg_Idx : Integer) return Integer;
-- Begins looking at Arg_Idx + 1 and returns the index of the
-- last character before a slash or else the index of the last
-- character in the string Argv.
function Get_Arg_End
(Argv : String;
- Arg_Idx : Integer)
- return Integer
+ Arg_Idx : Integer) return Integer
is
begin
for J in Arg_Idx + 1 .. Argv'Last loop
Arg1_Idx : Integer := Arg'First;
function Get_Arg1_End
- (Arg : String; Arg_Idx : Integer)
- return Integer;
+ (Arg : String;
+ Arg_Idx : Integer) return Integer;
-- Begins looking at Arg_Idx + 1 and
-- returns the index of the last character
-- before a comma or else the index of the
------------------
function Get_Arg1_End
- (Arg : String; Arg_Idx : Integer)
- return Integer
+ (Arg : String;
+ Arg_Idx : Integer) return Integer
is
begin
for J in Arg_Idx + 1 .. Arg'Last loop
-- /COMPILER_QUALIFIERS, /LINKER_QUALIFIERS and /MAKE_QUALIFIERS will be
-- passed to any GNAT BIND commands generated by GNAT MAKE.
+ S_Make_Bindprj : aliased constant S := "/BND_LNK_FULL_PROJECT " &
+ "-B";
+ -- /BND_LNK_FULL_PROJECT
+ --
+ -- Bind and link all sources of a project, without any consideration
+ -- to attribute Main, if there is one. This qualifier need to be
+ -- used in conjunction with the /PROJECT_FILE= qualifier and cannot
+ -- be used with a main subprogram on the command line or for
+ -- a library project file. As the binder is invoked with the option
+ -- meaning "No Ada main subprogram", the user must ensure that the
+ -- proper options are specified to the linker. This qualifier is
+ -- normally used when the main subprogram is in a foreign language
+ -- such as C.
+
S_Make_Comp : aliased constant S := "/COMPILER_QUALIFIERS=?" &
"-cargs COMPILE";
-- /COMPILER_QUALIFIERS
-- Write the output into the specified file, overriding any possibly
-- existing file.
+ S_Pretty_Formfeed : aliased constant S := "/FORM_FEED_AFTER_PRAGMA_PAGE " &
+ "-ff";
+ -- /FORM_FEED_AFTER_PRAGMA_PAGE
+ --
+ -- When there is a pragma Page in the source, insert a Form Feed
+ -- character immediately after the semicolon that follows the pragma
+ -- Page.
+
S_Pretty_Indent : aliased constant S := "/INDENTATION_LEVEL=#" &
"-i#";
-- /INDENTATION_LEVEL=nnn
S_Pretty_Current 'Access,
S_Pretty_Dico 'Access,
S_Pretty_Forced 'Access,
+ S_Pretty_Formfeed 'Access,
S_Pretty_Indent 'Access,
S_Pretty_Keyword 'Access,
S_Pretty_Maxlen 'Access,
-- --
-- B o d y --
-- --
--- Copyright (C) 2002, 2003 Ada Core Technologies, Inc. --
+-- Copyright (C) 2002-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- This program is meant to be used with vxworks to compute symbolic
-- backtraces on the host from non-symbolic backtraces obtained on the target.
---
+
-- The basic idea is to automate the computation of the necessary address
-- adjustments prior to calling addr2line when the application has only been
-- partially linked on the host.
---
+
-- Variants for various targets are supported, and the command line should
-- be like :
---
+
-- <target>-addr2line [-a <target_arch>] <exe_file> <ref_address>
-- <backtrace addresses>
---
+
-- Where:
-- <target_arch> :
-- selects the target architecture. In the absence of this parameter the
-- Otherwise, the command name will always be of the form
-- <target>-vxaddr2line where there is no ambiguity on the target's
-- architecture.
---
+
-- <exe_file> :
-- The name of the partially linked binary file for the application.
---
+
-- <ref_address> :
-- Runtime address (on the target) of a reference symbol you choose,
-- which name shall match the value of the Ref_Symbol variable declared
-- below. A symbol with a small offset from the beginning of the text
-- segment is better, so "adainit" is a good choice.
---
+
-- <backtrace addresses> :
-- The call chain addresses you obtained at run time on the target and
-- for which you want a symbolic association.
---
+
-- TO ADD A NEW ARCHITECTURE add an appropriate value to Architecture type
-- (in a format <host>_<target>), and then an appropriate value to Config_List
-- array
procedure VxAddr2Line is
- Ref_Symbol : String := "adainit";
+ Ref_Symbol : constant String := "adainit";
-- This is the name of the reference symbol which runtime address shall
-- be provided as the <ref_address> argument.
-----------------
procedure Detect_Arch is
- Name : String := Base_Name (Command_Name);
- Proc : String := Name (Name'First .. Index (Name, "-") - 1);
- Target : String := Name (Name'First .. Index (Name, "vxaddr2line") - 1);
+ Name : constant String := Base_Name (Command_Name);
+ Proc : constant String :=
+ Name (Name'First .. Index (Name, "-") - 1);
+ Target : constant String :=
+ Name (Name'First .. Index (Name, "vxaddr2line") - 1);
begin
Detect_Success := False;
Nm_Cmd : constant String_Access :=
Locate_Exec_On_Path (Arch_List (Cur_Arch).Nm_Binary.all);
- Nm_Args : Argument_List :=
+ Nm_Args : constant Argument_List :=
(new String'("-P"),
new String'(Argument (1)));
-- If we are here, the pattern was matched successfully
declare
- Match_String : String := Expect_Out_Match (Pd);
- Matches : Match_Array (0 .. 1);
- Value : Integer;
+ Match_String : constant String := Expect_Out_Match (Pd);
+ Matches : Match_Array (0 .. 1);
+ Value : Integer;
begin
Match (Reference, Match_String, Matches);
----------------------------
function Get_Value_From_Hex_Arg (Arg : Natural) return Integer is
+ Cur_Arg : constant String := Argument (Arg);
Offset : Natural;
- Cur_Arg : String := Argument (Arg);
begin
-- Skip "0x" prefix if present
function Get_File
(Decl : Declaration_Reference;
- With_Dir : Boolean := False)
- return String
+ With_Dir : Boolean := False) return String
is
begin
return Get_File (Decl.Decl.File, With_Dir);
function Get_File
(Ref : Reference;
- With_Dir : Boolean := False)
- return String
+ With_Dir : Boolean := False) return String
is
begin
return Get_File (Ref.File, With_Dir);
function Get_File
(File : File_Reference;
With_Dir : in Boolean := False;
- Strip : Natural := 0)
- return String
+ Strip : Natural := 0) return String
is
Tmp : GNAT.OS_Lib.String_Access;
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
function Get_File
(Decl : Declaration_Reference;
- With_Dir : Boolean := False)
- return String;
+ With_Dir : Boolean := False) return String;
+ pragma Inline (Get_File);
-- Extract column number or file name from reference
function Get_File
(Ref : Reference;
- With_Dir : Boolean := False)
- return String;
+ With_Dir : Boolean := False) return String;
pragma Inline (Get_File);
function Get_File
(File : File_Reference;
With_Dir : Boolean := False;
- Strip : Natural := 0)
- return String;
+ Strip : Natural := 0) return String;
-- Returns the file name (and its directory if With_Dir is True or the
-- user has used the -f switch on the command line. If Strip is not 0,
-- then the last Strip-th "-..." substrings are removed first. For
-- would be returned as "parent-child1.ali". This is used when looking
-- for the ALI file to use for a package, since for separates with have
-- to use the parent's ALI. The null string is returned if there is no
- -- such parent unit
+ -- such parent unit.
+ --
+ -- Note that this version of Get_File is not inlined
function Get_File_Ref (Ref : Reference) return File_Reference;
function Get_Line (Decl : Declaration_Reference) return String;
pragma Inline (Get_Column);
pragma Inline (Get_Emit_Warning);
- pragma Inline (Get_File);
pragma Inline (Get_File_Ref);
pragma Inline (Get_Line);
pragma Inline (Get_Symbol);
Line_Num : Natural := 0;
Col_Num : Natural := 0;
File_Ref : File_Reference := Empty_File;
- Has_Pattern : Boolean := False;
begin
-- Find the end of the first item in Entity (pattern or file?)
end;
end;
- File_Start := File_Start + 1;
- Has_Pattern := True;
+ File_Start := File_Start + 1;
end if;
-- Parse the file name
procedure Add_Xref_File (File : String) is
File_Ref : File_Reference := Empty_File;
+ pragma Unreferenced (File_Ref);
+
Iterator : Expansion_Iterator;
procedure Add_Xref_File_Internal (File : String);
if Tail (File, 4) = ".ali" then
File_Ref := Add_To_Xref_File
- (File, Visited => False, Emit_Warning => True);
+ (File, Visited => False, Emit_Warning => True);
-- Normal non-ali file case
File_Ref := Add_To_Xref_File (File, Visited => True);
File_Ref := Add_To_Xref_File
- (ALI_File_Name (File),
- Visited => False,
- Emit_Warning => True);
+ (ALI_File_Name (File),
+ Visited => False, Emit_Warning => True);
end if;
end Add_Xref_File_Internal;
--------------------
procedure Find_ALI_Files is
- My_Dir : Rec_DIR;
- Dir_Ent : File_Name_String;
- Last : Natural;
- File_Ref : File_Reference;
+ My_Dir : Rec_DIR;
+ Dir_Ent : File_Name_String;
+ Last : Natural;
+
+ File_Ref : File_Reference;
+ pragma Unreferenced (File_Ref);
function Open_Next_Dir return Boolean;
-- Tries to open the next object directory, and return False if
Token : Positive;
Ptr : Positive := Ali'First;
Num_Dependencies : Natural := 0;
- File_Ref : File_Reference;
File_Start : Positive;
File_End : Positive;
Gnatchop_Offset : Integer;
Gnatchop_Name : Positive;
+ File_Ref : File_Reference;
+ pragma Unreferenced (File_Ref);
+
begin
-- Read all the lines possibly processing with-clauses and dependency
-- information and exit on finding the first Xref line.
-- which is an error condition.
while Ali (Ptr) /= EOF loop
-
if D_Lines and then Ali (Ptr) = 'D' then
-- Found dependency information. Format looks like:
Parse_Token (Ali, Ptr, Token);
Parse_Token (Ali, Ptr, Token);
- File_Ref := Add_To_Xref_File
- (Ali (Token .. Ptr - 1), Visited => False);
+ File_Ref :=
+ Add_To_Xref_File (Ali (Token .. Ptr - 1), Visited => False);
elsif Ali (Ptr) = 'X' then
E_Line : Natural; -- Line number of current entity
E_Col : Natural; -- Column number of current entity
E_Name : Positive; -- Pointer to begin of entity name
- E_Type : Character; -- Type of current entity
begin
-- Look for the X lines corresponding to unit Eun
loop
Parse_Number (Ali, Ptr, E_Line);
- E_Type := Ali (Ptr);
exit when Ali (Ptr) = EOF;
Ptr := Ptr + 1;
Parse_Number (Ali, Ptr, E_Col);
Parse_Derived_Info : declare
P_Line : Natural; -- parent entity line
P_Column : Natural; -- parent entity column
- P_Type : Character; -- parent entity type
P_Eun : Positive; -- parent entity file number
begin
-- Then parse the type and column number
- P_Type := Ali (Ptr);
Ptr := Ptr + 1;
Parse_Number (Ali, Ptr, P_Column);
if Wide_Search then
declare
- File_Ref : File_Reference;
- File_Name : constant String :=
- Get_Gnatchop_File (File.X_File);
+ File_Ref : File_Reference;
+ pragma Unreferenced (File_Ref);
+ File_Name : constant String := Get_Gnatchop_File (File.X_File);
begin
File_Ref := Add_To_Xref_File (ALI_File_Name (File_Name), False);
end;
projects / gcc.git / commitdiff