diff options
Diffstat (limited to 'lang/gnat/files')
26 files changed, 515 insertions, 2344 deletions
diff --git a/lang/gnat/files/5fintman.adb b/lang/gnat/files/5fintman.adb deleted file mode 100644 index 2dbb0d8aa338..000000000000 --- a/lang/gnat/files/5fintman.adb +++ /dev/null @@ -1,217 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- --- -- --- B o d y -- --- (Version for new GNARL) -- --- -- --- $Revision: 1.3 $ -- --- -- --- Copyright (C) 1991,1992,1993,1994,1995,1996 Florida State University -- --- -- --- 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- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL 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 GNARL; 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. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. It is -- --- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- --- State University (http://www.gnat.com). -- --- -- ------------------------------------------------------------------------------- - --- This is the FreeBSD PTHREADS version of this package - --- This is only a first approximation. --- It should be autogenerated by the m4 macro processor. --- Contributed by Peter Burwood (gnat@arcangel.dircon.co.uk). - --- This file performs the system-dependent translation between machine --- exceptions and the Ada exceptions, if any, that should be raised when --- they occur. This version works for FreeBSD. Contributed by --- Daniel M. Eischen (eischen@vigrid.com). - --- PLEASE DO NOT add any dependences on other packages. --- This package is designed to work with or without tasking support. - --- See the other warnings in the package specification before making --- any modifications to this file. - --- Make a careful study of all signals available under the OS, --- to see which need to be reserved, kept always unmasked, --- or kept always unmasked. --- Be on the lookout for special signals that --- may be used by the thread library. - -with Interfaces.C; --- used for int and other types - -with System.OS_Interface; --- used for various Constants, Signal and types - -package body System.Interrupt_Management is - - use Interfaces.C; - use System.OS_Interface; - - type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID; - Exception_Interrupts : constant Interrupt_List := - (SIGFPE, SIGILL, SIGSEGV, SIGBUS); - - Unreserve_All_Interrupts : Interfaces.C.int; - pragma Import - (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts"); - - ---------------------- - -- Notify_Exception -- - ---------------------- - - Signal_Mask : aliased sigset_t; - -- The set of signals handled by Notify_Exception - - -- This function identifies the Ada exception to be raised using - -- the information when the system received a synchronous signal. - -- Since this function is machine and OS dependent, different code - -- has to be provided for different target. - - -- Language specs say signal handlers take exactly one arg, even - -- though FreeBSD actually supplies three. Ugh! - - procedure Notify_Exception - (signo : Signal; - code : Interfaces.C.int; - context : access struct_sigcontext); - - procedure Notify_Exception - (signo : Signal; - code : Interfaces.C.int; - context : access struct_sigcontext) is - Result : Interfaces.C.int; - begin - -- With the __builtin_longjmp, the signal mask is not restored, so we - -- need to restore it explicitely. - - Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null); - pragma Assert (Result = 0); - - -- Check that treatment of exception propagation here - -- is consistent with treatment of the abort signal in - -- System.Task_Primitives.Operations. - - case signo is - when SIGFPE => - raise Constraint_Error; - when SIGILL => - raise Constraint_Error; - when SIGSEGV => - raise Storage_Error; - when SIGBUS => - raise Storage_Error; - when others => - pragma Assert (False); - null; - end case; - end Notify_Exception; - - --------------------------- - -- Initialize_Interrupts -- - --------------------------- - - -- Nothing needs to be done on this platform. - - procedure Initialize_Interrupts is - begin - null; - end Initialize_Interrupts; - -begin - declare - act : aliased struct_sigaction; - old_act : aliased struct_sigaction; - Result : Interfaces.C.int; - - begin - - Abort_Task_Interrupt := SIGADAABORT; - -- Change this if you want to use another signal for task abort. - -- SIGTERM might be a good one. - - act.sa_handler := Notify_Exception'Address; - - act.sa_flags := 0; - - -- On some targets, we set sa_flags to SA_NODEFER so that during the - -- handler execution we do not change the Signal_Mask to be masked for - -- the Signal. - -- This is a temporary fix to the problem that the Signal_Mask is - -- not restored after the exception (longjmp) from the handler. - -- The right fix should be made in sigsetjmp so that we save - -- the Signal_Set and restore it after a longjmp. - -- Since SA_NODEFER is obsolete, instead we reset explicitely - -- the mask in the exception handler. - - Result := sigemptyset (Signal_Mask'Access); - pragma Assert (Result = 0); - - for I in Exception_Interrupts'Range loop - Result := - sigaddset - (Signal_Mask'Access, Signal (Exception_Interrupts (I))); - pragma Assert (Result = 0); - end loop; - - act.sa_mask := Signal_Mask; - - for I in Exception_Interrupts'Range loop - Keep_Unmasked (Exception_Interrupts (I)) := True; - Result := - sigaction - (Signal (Exception_Interrupts (I)), act'Unchecked_Access, - old_act'Unchecked_Access); - pragma Assert (Result = 0); - end loop; - - Keep_Unmasked (Abort_Task_Interrupt) := True; - - -- By keeping SIGINT unmasked, allow the user to do a Ctrl-C, but in the - -- same time, disable the ability of handling this signal - -- via Ada.Interrupts. - -- The pragma Unreserve_All_Interrupts let the user the ability to - -- change this behavior. - - if Unreserve_All_Interrupts = 0 then - Keep_Unmasked (SIGINT) := True; - end if; - - for I in Unmasked'Range loop - Keep_Unmasked (Interrupt_ID (Unmasked (I))) := True; - end loop; - - Reserve := Keep_Unmasked or Keep_Masked; - - for I in Reserved'Range loop - Reserve (Interrupt_ID (Reserved (I))) := True; - end loop; - - Reserve (0) := True; - -- We do not have Signal 0 in reality. We just use this value - -- to identify non-existent signals (see s-intnam.ads). Therefore, - -- Signal 0 should not be used in all signal related operations hence - -- mark it as reserved. - end; -end System.Interrupt_Management; diff --git a/lang/gnat/files/5ftaprop.adb b/lang/gnat/files/5ftaprop.adb deleted file mode 100644 index 7fac4bd7801c..000000000000 --- a/lang/gnat/files/5ftaprop.adb +++ /dev/null @@ -1,1154 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- $Revision: 1.33 $ --- -- --- Copyright (C) 1991-2000, Florida State University -- --- -- --- 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- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL 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 GNARL; 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. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. It is -- --- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- --- State University (http://www.gnat.com). -- --- -- ------------------------------------------------------------------------------- - --- This is the FreeBSD PTHREADS version of this package. Contributed --- by Daniel M. Eischen (eischen@vigrid.com). - --- This package contains all the GNULL primitives that interface directly --- with the underlying OS. - --- Note: this file can only be used for POSIX compliant systems that --- implement SCHED_FIFO and Ceiling Locking correctly (that is, for now: --- FSU Threads, RTEMS Threads, and FreeBSD Threads). - --- For configurations where SCHED_FIFO and priority ceiling are not a --- requirement, this file can also be used (e.g AiX threads) - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -with System.Tasking.Debug; --- used for Known_Tasks - -with System.Task_Info; --- used for Task_Info_Type - -with Interfaces.C; --- used for int --- size_t - -with System.Interrupt_Management; --- used for Keep_Unmasked --- Abort_Task_Interrupt --- Interrupt_ID - -with System.Interrupt_Management.Operations; --- used for Set_Interrupt_Mask --- All_Tasks_Mask -pragma Elaborate_All (System.Interrupt_Management.Operations); - -with System.Parameters; --- used for Size_Type - -with System.Tasking; --- used for Ada_Task_Control_Block --- Task_ID - -with System.Soft_Links; --- used for Defer/Undefer_Abort - --- Note that we do not use System.Tasking.Initialization directly since --- this is a higher level package that we shouldn't depend on. For example --- when using the restricted run time, it is replaced by --- System.Tasking.Restricted.Initialization - -with System.OS_Primitives; --- used for Delay_Modes - -with Unchecked_Conversion; -with Unchecked_Deallocation; - -package body System.Task_Primitives.Operations is - - use System.Tasking.Debug; - use System.Tasking; - use Interfaces.C; - use System.OS_Interface; - use System.Parameters; - use System.OS_Primitives; - - package SSL renames System.Soft_Links; - - pragma Linker_Options ("-pthread"); - - ---------------- - -- Local Data -- - ---------------- - - -- The followings are logically constants, but need to be initialized - -- at run time. - - Single_RTS_Lock : aliased RTS_Lock; - -- This is a lock to allow only one thread of control in the RTS at - -- a time; it is used to execute in mutual exclusion from all other tasks. - -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List - - Environment_Task_ID : Task_ID; - -- A variable to hold Task_ID for the environment task. - - Locking_Policy : Character; - pragma Import (C, Locking_Policy, "__gl_locking_policy"); - -- Value of the pragma Locking_Policy: - -- 'C' for Ceiling_Locking - -- 'I' for Inherit_Locking - -- ' ' for none. - - Unblocked_Signal_Mask : aliased sigset_t; - -- The set of signals that should unblocked in all tasks - - -- The followings are internal configuration constants needed. - - Next_Serial_Number : Task_Serial_Number := 100; - -- We start at 100, to reserve some special values for - -- using in error checking. - - Time_Slice_Val : Integer; - pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); - - Dispatching_Policy : Character; - pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - - FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; - -- Indicates whether FIFO_Within_Priorities is set. - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Abort_Handler (Sig : Signal); - - function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID); - - function To_Address is new Unchecked_Conversion (Task_ID, System.Address); - - -------------------- - -- Local Packages -- - -------------------- - - package Specific is - - procedure Initialize (Environment_Task : Task_ID); - pragma Inline (Initialize); - -- Initialize various data needed by this package. - - procedure Set (Self_Id : Task_ID); - pragma Inline (Set); - -- 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. - - end Specific; - - package body Specific is separate; - -- The body of this package is target specific. - - ------------------- - -- Abort_Handler -- - ------------------- - - -- Target-dependent binding of inter-thread Abort signal to - -- the raising of the Abort_Signal exception. - - -- The technical issues and alternatives here are essentially - -- the same as for raising exceptions in response to other - -- signals (e.g. Storage_Error). See code and comments in - -- the package body System.Interrupt_Management. - - -- Some implementations may not allow an exception to be propagated - -- out of a handler, and others might leave the signal or - -- interrupt that invoked this handler masked after the exceptional - -- return to the application code. - - -- GNAT exceptions are originally implemented using setjmp()/longjmp(). - -- On most UNIX systems, this will allow transfer out of a signal handler, - -- which is usually the only mechanism available for implementing - -- asynchronous handlers of this kind. However, some - -- systems do not restore the signal mask on longjmp(), leaving the - -- abort signal masked. - - -- Alternative solutions include: - - -- 1. Change the PC saved in the system-dependent Context - -- parameter to point to code that raises the exception. - -- Normal return from this handler will then raise - -- the exception after the mask and other system state has - -- been restored (see example below). - - -- 2. Use siglongjmp()/sigsetjmp() to implement exceptions. - - -- 3. Unmask the signal in the Abortion_Signal exception handler - -- (in the RTS). - - -- The following procedure would be needed if we can't lonjmp out of - -- a signal handler (See below) - - -- procedure Raise_Abort_Signal is - -- begin - -- raise Standard'Abort_Signal; - -- end if; - - procedure Abort_Handler - (Sig : Signal) is - - T : Task_ID := Self; - Result : Interfaces.C.int; - Old_Set : aliased sigset_t; - - begin - -- Assuming it is safe to longjmp out of a signal handler, the - -- following code can be used: - - if T.Deferral_Level = 0 - and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then - not T.Aborting - then - T.Aborting := True; - - -- Make sure signals used for RTS internal purpose are unmasked - - Result := pthread_sigmask (SIG_UNBLOCK, - Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); - pragma Assert (Result = 0); - - raise Standard'Abort_Signal; - end if; - - -- Otherwise, something like this is required: - -- if not Abort_Is_Deferred.all then - -- -- Overwrite the return PC address with the address of the - -- -- special raise routine, and "return" to that routine's - -- -- starting address. - -- Context.PC := Raise_Abort_Signal'Address; - -- return; - -- end if; - end Abort_Handler; - - ----------------- - -- Stack_Guard -- - ----------------- - - procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is - Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread); - Guard_Page_Address : Address; - - Res : Interfaces.C.int; - - begin - if Stack_Base_Available then - -- Compute the guard page address - - Guard_Page_Address := - Stack_Base - (Stack_Base mod Get_Page_Size) + Get_Page_Size; - - if On then - Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_ON); - else - Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_OFF); - end if; - - pragma Assert (Res = 0); - end if; - end Stack_Guard; - - -------------------- - -- Get_Thread_Id -- - -------------------- - - function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is - begin - return T.Common.LL.Thread; - end Get_Thread_Id; - - ---------- - -- Self -- - ---------- - - function Self return Task_ID renames Specific.Self; - - --------------------- - -- Initialize_Lock -- - --------------------- - - -- Note: mutexes and cond_variables needed per-task basis are - -- initialized in Intialize_TCB and the Storage_Error is - -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) - -- used in RTS is initialized before any status change of RTS. - -- Therefore rasing Storage_Error in the following routines - -- should be able to be handled safely. - - procedure Initialize_Lock - (Prio : System.Any_Priority; - L : access Lock) - is - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - if Locking_Policy = 'C' then - Result := pthread_mutexattr_setprotocol - (Attributes'Access, PTHREAD_PRIO_PROTECT); - pragma Assert (Result = 0); - - Result := pthread_mutexattr_setprioceiling - (Attributes'Access, Interfaces.C.int (Prio)); - pragma Assert (Result = 0); - - elsif Locking_Policy = 'I' then - Result := pthread_mutexattr_setprotocol - (Attributes'Access, PTHREAD_PRIO_INHERIT); - pragma Assert (Result = 0); - end if; - - Result := pthread_mutex_init (L, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); - end Initialize_Lock; - - procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - if Locking_Policy = 'C' then - Result := pthread_mutexattr_setprotocol - (Attributes'Access, PTHREAD_PRIO_PROTECT); - pragma Assert (Result = 0); - - Result := pthread_mutexattr_setprioceiling - (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); - pragma Assert (Result = 0); - - elsif Locking_Policy = 'I' then - Result := pthread_mutexattr_setprotocol - (Attributes'Access, PTHREAD_PRIO_INHERIT); - pragma Assert (Result = 0); - end if; - - Result := pthread_mutex_init (L, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - Result := pthread_mutexattr_destroy (Attributes'Access); - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); - end Initialize_Lock; - - ------------------- - -- Finalize_Lock -- - ------------------- - - procedure Finalize_Lock (L : access Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_destroy (L); - pragma Assert (Result = 0); - end Finalize_Lock; - - procedure Finalize_Lock (L : access RTS_Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_destroy (L); - pragma Assert (Result = 0); - end Finalize_Lock; - - ---------------- - -- Write_Lock -- - ---------------- - - procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_lock (L); - - -- Assume that the cause of EINVAL is a priority ceiling violation - - Ceiling_Violation := (Result = EINVAL); - pragma Assert (Result = 0 or else Result = EINVAL); - end Write_Lock; - - procedure Write_Lock - (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); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - 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); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - --------------- - -- Read_Lock -- - --------------- - - procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - begin - Write_Lock (L, Ceiling_Violation); - end Read_Lock; - - ------------ - -- Unlock -- - ------------ - - procedure Unlock (L : access Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_unlock (L); - pragma Assert (Result = 0); - end Unlock; - - 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); - pragma Assert (Result = 0); - end if; - end Unlock; - - 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); - pragma Assert (Result = 0); - end if; - end Unlock; - - ----------- - -- Sleep -- - ----------- - - procedure Sleep - (Self_ID : Task_ID; - Reason : System.Tasking.Task_States) - is - Result : Interfaces.C.int; - begin - if Single_Lock then - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); - else - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); - end if; - - -- EINTR is not considered a failure. - - pragma Assert (Result = 0 or else Result = EINTR); - end Sleep; - - ----------------- - -- Timed_Sleep -- - ----------------- - - -- This is for use within the run-time system, so abort is - -- assumed to be already deferred, and the caller should be - -- holding its own ATCB lock. - - procedure Timed_Sleep - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes; - Reason : Task_States; - Timedout : out Boolean; - Yielded : out Boolean) - is - Check_Time : constant Duration := Monotonic_Clock; - Rel_Time : Duration; - Abs_Time : Duration; - Request : aliased timespec; - Result : Interfaces.C.int; - - begin - Timedout := True; - Yielded := False; - - if Mode = Relative then - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; - - if Relative_Timed_Wait then - Rel_Time := Duration'Min (Max_Sensible_Delay, Time); - end if; - - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - - if Relative_Timed_Wait then - Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); - end if; - end if; - - if Abs_Time > Check_Time then - if Relative_Timed_Wait then - Request := To_Timespec (Rel_Time); - else - Request := To_Timespec (Abs_Time); - end if; - - loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - or else Self_ID.Pending_Priority_Change; - - if Single_Lock then - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access, - Request'Access); - - else - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, - Request'Access); - end if; - - exit when Abs_Time <= Monotonic_Clock; - - if Result = 0 or Result = EINTR then - - -- Somebody may have called Wakeup for us - - Timedout := False; - exit; - end if; - - pragma Assert (Result = ETIMEDOUT); - end loop; - end if; - end Timed_Sleep; - - ----------------- - -- Timed_Delay -- - ----------------- - - -- This is for use in implementing delay statements, so - -- we assume the caller is abort-deferred but is holding - -- no locks. - - procedure Timed_Delay - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes) - is - Check_Time : constant Duration := Monotonic_Clock; - Abs_Time : Duration; - Rel_Time : Duration; - Request : aliased timespec; - Result : Interfaces.C.int; - - begin - -- Only the little window between deferring abort and - -- locking Self_ID is the reason we need to - -- check for pending abort and priority change below! :( - - SSL.Abort_Defer.all; - - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (Self_ID); - - if Mode = Relative then - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; - - if Relative_Timed_Wait then - Rel_Time := Duration'Min (Max_Sensible_Delay, Time); - end if; - - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - - if Relative_Timed_Wait then - Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); - end if; - end if; - - if Abs_Time > Check_Time then - if Relative_Timed_Wait then - Request := To_Timespec (Rel_Time); - else - Request := To_Timespec (Abs_Time); - end if; - - Self_ID.Common.State := Delay_Sleep; - - loop - if Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - - if Single_Lock then - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, Request'Access); - else - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, Request'Access); - end if; - - exit when Abs_Time <= Monotonic_Clock; - - pragma Assert (Result = 0 - or else Result = ETIMEDOUT - or else Result = EINTR); - end loop; - - Self_ID.Common.State := Runnable; - end if; - - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - Result := sched_yield; - SSL.Abort_Undefer.all; - end Timed_Delay; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - 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); - pragma Assert (Result = 0); - return To_Duration (TS); - end Monotonic_Clock; - - ------------------- - -- RT_Resolution -- - ------------------- - - function RT_Resolution return Duration is - begin - return 10#1.0#E-6; - end RT_Resolution; - - ------------ - -- Wakeup -- - ------------ - - procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is - Result : Interfaces.C.int; - begin - Result := pthread_cond_signal (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Wakeup; - - ----------- - -- Yield -- - ----------- - - procedure Yield (Do_Yield : Boolean := True) is - Result : Interfaces.C.int; - begin - if Do_Yield then - Result := sched_yield; - end if; - end Yield; - - ------------------ - -- Set_Priority -- - ------------------ - - procedure Set_Priority - (T : Task_ID; - Prio : System.Any_Priority; - Loss_Of_Inheritance : Boolean := False) - is - Result : Interfaces.C.int; - Param : aliased struct_sched_param; - - begin - T.Common.Current_Priority := Prio; - Param.sched_priority := Interfaces.C.int (Prio); - - if Time_Slice_Supported and then Time_Slice_Val > 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_RR, Param'Access); - - elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_FIFO, Param'Access); - - else - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_OTHER, Param'Access); - end if; - - pragma Assert (Result = 0); - end Set_Priority; - - ------------------ - -- Get_Priority -- - ------------------ - - function Get_Priority (T : Task_ID) return System.Any_Priority is - begin - return T.Common.Current_Priority; - end Get_Priority; - - ---------------- - -- Enter_Task -- - ---------------- - - procedure Enter_Task (Self_ID : Task_ID) is - begin - Self_ID.Common.LL.Thread := pthread_self; - Self_ID.Common.LL.LWP := lwp_self; - - Specific.Set (Self_ID); - - Lock_RTS; - - for J in Known_Tasks'Range loop - if Known_Tasks (J) = null then - Known_Tasks (J) := Self_ID; - Self_ID.Known_Tasks_Index := J; - exit; - end if; - end loop; - - Unlock_RTS; - end Enter_Task; - - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - - ---------------------- - -- Initialize_TCB -- - ---------------------- - - 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; - - begin - -- Give the task a unique serial number. - - Self_ID.Serial_Number := Next_Serial_Number; - Next_Serial_Number := Next_Serial_Number + 1; - pragma Assert (Next_Serial_Number /= 0); - - if not Single_Lock then - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - if Locking_Policy = 'C' then - Result := pthread_mutexattr_setprotocol - (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT); - pragma Assert (Result = 0); - - Result := pthread_mutexattr_setprioceiling - (Mutex_Attr'Access, - Interfaces.C.int (System.Any_Priority'Last)); - pragma Assert (Result = 0); - - elsif Locking_Policy = 'I' then - Result := pthread_mutexattr_setprotocol - (Mutex_Attr'Access, PTHREAD_PRIO_INHERIT); - pragma Assert (Result = 0); - end if; - - Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, - Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result = 0 then - Succeeded := True; - else - if not Single_Lock then - Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Succeeded := False; - end if; - - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - end Initialize_TCB; - - ----------------- - -- Create_Task -- - ----------------- - - procedure Create_Task - (T : Task_ID; - Wrapper : System.Address; - Stack_Size : System.Parameters.Size_Type; - Priority : System.Any_Priority; - Succeeded : out Boolean) - is - Attributes : aliased pthread_attr_t; - Adjusted_Stack_Size : Interfaces.C.size_t; - Result : Interfaces.C.int; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - use System.Task_Info; - - begin - if Stack_Size = Unspecified_Size then - Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size); - - elsif Stack_Size < Minimum_Stack_Size then - Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size); - - else - Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); - 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 - -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages - -- to be sure the effective stack size is greater than what - -- has been asked. - - Adjusted_Stack_Size := Adjusted_Stack_Size + 2 * Get_Page_Size; - end if; - - Result := pthread_attr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_attr_setdetachstate - (Attributes'Access, PTHREAD_CREATE_DETACHED); - pragma Assert (Result = 0); - - Result := pthread_attr_setstacksize - (Attributes'Access, Adjusted_Stack_Size); - pragma Assert (Result = 0); - - if T.Common.Task_Info /= Default_Scope then - - -- We are assuming that Scope_Type has the same values than the - -- corresponding C macros - - Result := pthread_attr_setscope - (Attributes'Access, Task_Info_Type'Pos (T.Common.Task_Info)); - pragma Assert (Result = 0); - end if; - - -- Since the initial signal mask of a thread is inherited from the - -- creator, and the Environment task has all its signals masked, we - -- do not need to manipulate caller's signal mask at this point. - -- All tasks in RTS will have All_Tasks_Mask initially. - - Result := pthread_create - (T.Common.LL.Thread'Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); - pragma Assert (Result = 0 or else Result = EAGAIN); - - Succeeded := Result = 0; - - if T.Common.Task_Image /= null then - declare - Name : aliased String (1 .. T.Common.Task_Image.all'Length + 1); - begin - Name := T.Common.Task_Image.all & ASCII.Nul; - Result := pthread_set_name_np (T.Common.LL.Thread, Name'Address); - end; - end if; - - Result := pthread_attr_destroy (Attributes'Access); - pragma Assert (Result = 0); - - Set_Priority (T, Priority); - end Create_Task; - - ------------------ - -- Finalize_TCB -- - ------------------ - - procedure Finalize_TCB (T : Task_ID) is - Result : Interfaces.C.int; - Tmp : Task_ID := T; - - procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); - - begin - if not Single_Lock then - Result := pthread_mutex_destroy (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_cond_destroy (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - - if T.Known_Tasks_Index /= -1 then - Known_Tasks (T.Known_Tasks_Index) := null; - end if; - - Free (Tmp); - end Finalize_TCB; - - --------------- - -- Exit_Task -- - --------------- - - procedure Exit_Task is - begin - pthread_exit (System.Null_Address); - end Exit_Task; - - ---------------- - -- Abort_Task -- - ---------------- - - 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)); - pragma Assert (Result = 0); - end Abort_Task; - - ---------------- - -- Check_Exit -- - ---------------- - - -- Dummy versions. The only currently working versions is for solaris - -- (native). - - function Check_Exit (Self_ID : ST.Task_ID) return Boolean is - begin - return True; - end Check_Exit; - - -------------------- - -- Check_No_Locks -- - -------------------- - - function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is - begin - return True; - end Check_No_Locks; - - ---------------------- - -- Environment_Task -- - ---------------------- - - function Environment_Task return Task_ID is - begin - return Environment_Task_ID; - end Environment_Task; - - -------------- - -- Lock_RTS -- - -------------- - - procedure Lock_RTS is - begin - Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); - end Lock_RTS; - - ---------------- - -- Unlock_RTS -- - ---------------- - - procedure Unlock_RTS is - begin - Unlock (Single_RTS_Lock'Access, Global_Lock => True); - end Unlock_RTS; - - ------------------ - -- Suspend_Task -- - ------------------ - - function Suspend_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) return Boolean is - begin - return False; - end Suspend_Task; - - ----------------- - -- Resume_Task -- - ----------------- - - function Resume_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) return Boolean is - begin - return False; - end Resume_Task; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Environment_Task : Task_ID) is - act : aliased struct_sigaction; - old_act : aliased struct_sigaction; - Tmp_Set : aliased sigset_t; - Result : Interfaces.C.int; - - begin - Environment_Task_ID := Environment_Task; - - -- Initialize the lock used to synchronize chain of all ATCBs. - - Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); - - Specific.Initialize (Environment_Task); - - Enter_Task (Environment_Task); - - -- Install the abort-signal handler - - act.sa_flags := 0; - act.sa_handler := Abort_Handler'Address; - - Result := sigemptyset (Tmp_Set'Access); - pragma Assert (Result = 0); - act.sa_mask := Tmp_Set; - - Result := - sigaction ( - Signal (System.Interrupt_Management.Abort_Task_Interrupt), - act'Unchecked_Access, - old_act'Unchecked_Access); - - pragma Assert (Result = 0); - end Initialize; - -begin - declare - Result : Interfaces.C.int; - begin - -- Mask Environment task for all signals. The original mask of the - -- Environment task will be recovered by Interrupt_Server task - -- during the elaboration of s-interr.adb. - - System.Interrupt_Management.Operations.Set_Interrupt_Mask - (System.Interrupt_Management.Operations.All_Tasks_Mask'Access); - - -- Prepare the set of signals that should unblocked in all tasks - - Result := sigemptyset (Unblocked_Signal_Mask'Access); - pragma Assert (Result = 0); - - for J in Interrupt_Management.Interrupt_ID loop - if System.Interrupt_Management.Keep_Unmasked (J) then - Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); - pragma Assert (Result = 0); - end if; - end loop; - end; -end System.Task_Primitives.Operations; diff --git a/lang/gnat/files/5ftaspri.ads b/lang/gnat/files/5ftaspri.ads deleted file mode 100644 index e38d94f5068f..000000000000 --- a/lang/gnat/files/5ftaspri.ads +++ /dev/null @@ -1,128 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K _ P R I M I T I V E S -- --- -- --- S p e c -- --- -- --- $Revision: 1.1 $ -- --- -- --- Copyright (C) 1991-1997, 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- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL 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 GNARL; 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. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. It is -- --- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- --- State University (http://www.gnat.com). -- --- -- ------------------------------------------------------------------------------- - --- This is the FreeBSD PTHREADS version of this package. Contributed --- by Daniel M. Eischen (eischen@vigrid.com). - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -with Interfaces.C; --- used for int --- size_t - -with System.OS_Interface; --- used for pthread_mutex_t --- pthread_cond_t --- pthread_t - -package System.Task_Primitives is - - type Lock is limited private; - -- Should be used for implementation of protected objects. - - type RTS_Lock is limited private; - -- Should be used inside the runtime system. - -- The difference between Lock and the RTS_Lock is that the later - -- one serves only as a semaphore so that do not check for - -- ceiling violations. - - type Task_Body_Access is access procedure; - -- Pointer to the task body's entry point (or possibly a wrapper - -- declared local to the GNARL). - - type Private_Data is limited private; - -- Any information that the GNULLI needs maintained on a per-task - -- basis. A component of this type is guaranteed to be included - -- in the Ada_Task_Control_Block. - -private - - type Lock is new System.OS_Interface.pthread_mutex_t; - type RTS_Lock is new System.OS_Interface.pthread_mutex_t; - - type Private_Data is record - Thread : aliased System.OS_Interface.pthread_t; - pragma Atomic (Thread); - -- Thread field may be updated by two different threads of control. - -- (See, Enter_Task and Create_Task in s-taprop.adb). - -- They put the same value (thr_self value). We do not want to - -- use lock on those operations and the only thing we have to - -- make sure is that they are updated in atomic fashion. - - LWP : aliased System.Address; - -- This field is not relevant on all targets. Currently only SGI and - -- AiX updates it. The purpose of this field is to provide a better - -- tasking support on gdb. The order of the two first fields (Thread - -- and LWP) is important. - - CV : aliased System.OS_Interface.pthread_cond_t; - - L : aliased RTS_Lock; - -- Protection for all components is lock L - - Current_Priority : Interfaces.C.int := 0; - -- Active priority, except that the effects of protected object - -- priority ceilings are not reflected. This only reflects explicit - -- priority changes and priority inherited through task activation - -- and rendezvous. - -- - -- Ada 95 notes: In Ada 95, this field will be transferred to the - -- Priority field of an Entry_Calls component when an entry call - -- is initiated. The Priority of the Entry_Calls component will not - -- change for the duration of the call. The accepting task can - -- use it to boost its own priority without fear of its changing in - -- the meantime. - -- - -- This can safely be used in the priority ordering - -- of entry queues. Once a call is queued, its priority does not - -- change. - -- - -- Since an entry call cannot be made while executing - -- a protected action, the priority of a task will never reflect a - -- priority ceiling change at the point of an entry call. - -- - -- Protection: Only written by Self, and only accessed when Acceptor - -- accepts an entry or when Created activates, at which points Self is - -- suspended. - - Stack_Size : Interfaces.C.size_t; - -- Requested stack size. - -- Protection: Only used by Self. - end record; - -end System.Task_Primitives; diff --git a/lang/gnat/files/4fintnam.ads b/lang/gnat/files/a-intnam-freebsd.ads index eea386d04723..329b0f6508ff 100644 --- a/lang/gnat/files/4fintnam.ads +++ b/lang/gnat/files/a-intnam-freebsd.ads @@ -1,15 +1,12 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- -- A D A . I N T E R R U P T S . N A M E S -- -- -- -- S p e c -- --- (Version for new GNARL) -- -- -- --- $Revision: 1.1 $ -- --- -- --- Copyright (C) 1991,92,93,94,95,1996 Free Software Foundation, Inc. -- +-- Copyright (C) 1991-2005, 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- -- @@ -19,8 +16,8 @@ -- 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 GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, 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, -- @@ -29,24 +26,18 @@ -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- --- GNARL was developed by the GNARL team at Florida State University. It is -- --- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- --- State University (http://www.gnat.com). -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ -- This is the FreeBSD THREADS version of this package --- This is only a first approximation. --- It should be autogenerated by the m4 macro processor. --- Contributed by Daniel Eischen (eischen@vigrid.com) - with System.OS_Interface; -- used for names of interrupts package Ada.Interrupts.Names is - SIGHUP : constant Interrupt_ID := System.OS_Interface.SIGHUP; -- hangup @@ -68,9 +59,6 @@ package Ada.Interrupts.Names is SIGABRT : constant Interrupt_ID := -- used by abort, System.OS_Interface.SIGABRT; -- replace SIGIOT in the future - SIGEMT : constant Interrupt_ID := - System.OS_Interface.SIGEMT; -- EMT instruction - SIGFPE : constant Interrupt_ID := System.OS_Interface.SIGFPE; -- floating point exception @@ -83,9 +71,6 @@ package Ada.Interrupts.Names is SIGSEGV : constant Interrupt_ID := System.OS_Interface.SIGSEGV; -- segmentation violation - SIGSYS : constant Interrupt_ID := - System.OS_Interface.SIGSYS; -- bad argument to system call - SIGPIPE : constant Interrupt_ID := -- write on a pipe with System.OS_Interface.SIGPIPE; -- no one to read it @@ -137,9 +122,6 @@ package Ada.Interrupts.Names is SIGWINCH : constant Interrupt_ID := System.OS_Interface.SIGWINCH; -- window size change - SIGINFO : constant Interrupt_ID := -- information request - System.OS_Interface.SIGINFO; -- (NetBSD/FreeBSD) - SIGUSR1 : constant Interrupt_ID := System.OS_Interface.SIGUSR1; -- user defined signal 1 diff --git a/lang/gnat/files/freebsd5x-patch-01 b/lang/gnat/files/freebsd5x-patch-01 deleted file mode 100644 index 176a094fc779..000000000000 --- a/lang/gnat/files/freebsd5x-patch-01 +++ /dev/null @@ -1,15 +0,0 @@ ---- ./config/i386/freebsd.h.orig Tue Nov 26 12:56:06 2002 -+++ ./config/i386/freebsd.h Tue Nov 26 12:57:30 2002 -@@ -165,10 +165,10 @@ - "%{!shared: \ - %{!pg: \ - %{!pthread: %{!kthread:-lc} %{kthread:-lpthread -lc}} \ -- %{pthread:-lc_r}} \ -+ %{pthread:-lc_r -lc}} \ - %{pg: \ - %{!pthread: %{!kthread:-lc_p} %{kthread:-lpthread_p -lc_p}} \ -- %{pthread:-lc_r_p}}}" -+ %{pthread:-lc_r_p -lc_p}}}" - #else - #define LIB_SPEC \ - "%{!shared: \ diff --git a/lang/gnat/files/g-soccon-freebsd.ads b/lang/gnat/files/g-soccon-freebsd.ads new file mode 100644 index 000000000000..964e75bc83be --- /dev/null +++ b/lang/gnat/files/g-soccon-freebsd.ads @@ -0,0 +1,181 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . C O N S T A N T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2005, 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- -- +-- 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, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, 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 target dependent definitions of constant for use +-- by the GNAT.Sockets package (g-socket.ads). This package should not be +-- directly with'ed by an applications program. + +-- This is the version for i386-unknown-freebsd5.2.1 +-- This file is generated automatically, do not modify it by hand! Instead, +-- make changes to gen-soccon.c and re-run it on each target. + +package GNAT.Sockets.Constants is + + -------------- + -- Families -- + -------------- + + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 28; -- IPv6 address family + + ----------- + -- Modes -- + ----------- + + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket + + ------------------- + -- Socket errors -- + ------------------- + + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 48; -- Address already in use + EADDRNOTAVAIL : constant := 49; -- Cannot assign address + EAFNOSUPPORT : constant := 47; -- Addr family not supported + EALREADY : constant := 37; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 53; -- Connection aborted + ECONNREFUSED : constant := 61; -- Connection refused + ECONNRESET : constant := 54; -- Connection reset by peer + EDESTADDRREQ : constant := 39; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 64; -- Host is down + EHOSTUNREACH : constant := 65; -- No route to host + EINPROGRESS : constant := 36; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 56; -- Socket already connected + ELOOP : constant := 62; -- Too many symbolic lynks + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 40; -- Message too long + ENAMETOOLONG : constant := 63; -- Name too long + ENETDOWN : constant := 50; -- Network is down + ENETRESET : constant := 52; -- Disconn. on network reset + ENETUNREACH : constant := 51; -- Network is unreachable + ENOBUFS : constant := 55; -- No buffer space available + ENOPROTOOPT : constant := 42; -- Protocol not available + ENOTCONN : constant := 57; -- Socket not connected + ENOTSOCK : constant := 38; -- Operation on non socket + EOPNOTSUPP : constant := 45; -- Operation not supported + EPFNOSUPPORT : constant := 46; -- Unknown protocol family + EPROTONOSUPPORT : constant := 43; -- Unknown protocol + EPROTOTYPE : constant := 41; -- Unknown protocol type + ESHUTDOWN : constant := 58; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported + ETIMEDOUT : constant := 60; -- Connection timed out + ETOOMANYREFS : constant := 59; -- Too many references + EWOULDBLOCK : constant := 35; -- Operation would block + + ----------------- + -- Host errors -- + ----------------- + + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors + + ------------------- + -- Control flags -- + ------------------- + + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read + + -------------------- + -- Shutdown modes -- + -------------------- + + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send + + --------------------- + -- Protocol levels -- + --------------------- + + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP + + ------------------- + -- Request flags -- + ------------------- + + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send + MSG_Forced_Flags : constant := 0; + -- Flags set on all send(2) calls + + -------------------- + -- Socket options -- + -------------------- + + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_SNDTIMEO : constant := 4101; -- Emission timeout + SO_RCVTIMEO : constant := 4102; -- Reception timeout + SO_ERROR : constant := 4103; -- Get/clear error status + IP_MULTICAST_IF : constant := 9; -- Set/get mcast interface + IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback + IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group + + ------------------- + -- System limits -- + ------------------- + + IOV_MAX : constant := 1024; -- Maximum writev iovcnt + + ---------------------- + -- Type definitions -- + ---------------------- + + -- Sizes (in bytes) of the components of struct timeval + + SIZEOF_tv_sec : constant := 4; -- tv_sec + SIZEOF_tv_usec : constant := 4; -- tv_usec + +end GNAT.Sockets.Constants; diff --git a/lang/gnat/files/patch-aa b/lang/gnat/files/patch-aa index 458d032c78b3..88604666bb74 100644 --- a/lang/gnat/files/patch-aa +++ b/lang/gnat/files/patch-aa @@ -1,57 +1,11 @@ -*** ./Makefile.in.orig Fri Nov 5 19:52:38 1999 ---- ./Makefile.in Sat Nov 6 10:07:16 1999 -*************** -*** 152,158 **** - ENQUIRE_LDFLAGS = $(LDFLAGS) - - # Sed command to transform gcc to installed name. Overwritten by configure. -! program_transform_name = -e s,x,x, - program_transform_cross_name = -e s,^,$(target_alias)-, - - # Tools to use when building a cross-compiler. ---- 152,158 ---- - ENQUIRE_LDFLAGS = $(LDFLAGS) - - # Sed command to transform gcc to installed name. Overwritten by configure. -! program_transform_name = -e s,^,ada, - program_transform_cross_name = -e s,^,$(target_alias)-, - - # Tools to use when building a cross-compiler. -*************** -*** 2151,2157 **** - # Install the driver last so that the window when things are - # broken is small. - install-normal: install-common $(INSTALL_HEADERS) $(INSTALL_LIBGCC) \ -! install-man install-info lang.install-normal install-driver - - # Do nothing while making gcc with a cross-compiler. The person who - # makes gcc for the target machine has to know how to put a complete ---- 2151,2157 ---- - # Install the driver last so that the window when things are - # broken is small. - install-normal: install-common $(INSTALL_HEADERS) $(INSTALL_LIBGCC) \ -! install-man lang.install-normal install-driver - - # Do nothing while making gcc with a cross-compiler. The person who - # makes gcc for the target machine has to know how to put a complete -*************** -*** 2241,2249 **** - # Install gcov if it was compiled. - -if [ -f gcov$(exeext) ]; \ - then \ -! rm -f $(bindir)/gcov$(exeext); \ -! $(INSTALL_PROGRAM) gcov$(exeext) $(bindir)/gcov$(exeext); \ -! chmod a+x $(bindir)/gcov$(exeext); \ - fi - - # Install the driver program as $(target_alias)-gcc ---- 2241,2249 ---- - # Install gcov if it was compiled. - -if [ -f gcov$(exeext) ]; \ - then \ -! rm -f $(bindir)/adagcov$(exeext); \ -! $(INSTALL_PROGRAM) gcov$(exeext) $(bindir)/adagcov$(exeext); \ -! chmod a+x $(bindir)/adagcov$(exeext); \ - fi - - # Install the driver program as $(target_alias)-gcc +--- gcc/Makefile.in.orig Wed Nov 23 23:55:21 2005 ++++ gcc/Makefile.in Thu Nov 24 10:47:11 2005 +@@ -2871,7 +2871,7 @@ + # Install the driver last so that the window when things are + # broken is small. + install: install-common $(INSTALL_HEADERS) $(INSTALL_LIBGCC) \ +- install-cpp install-man install-info install-@POSUB@ \ ++ install-cpp install-man install-@POSUB@ \ + lang.install-normal install-driver + + # Handle cpp installation. diff --git a/lang/gnat/files/patch-ab b/lang/gnat/files/patch-ab deleted file mode 100644 index 24f08d14a13d..000000000000 --- a/lang/gnat/files/patch-ab +++ /dev/null @@ -1,18 +0,0 @@ ---- config/i386/freebsd.h.orig Mon Nov 25 07:16:22 2002 -+++ config/i386/freebsd.h Mon Nov 25 09:18:52 2002 -@@ -162,8 +162,13 @@ - * -lc_p or -ggdb to LDFLAGS at the link time, respectively. - */ - #define LIB_SPEC \ -- "%{!shared: %{mieee-fp:-lieee} %{p:-lgmon} %{pg:-lgmon} \ -- %{!ggdb:-lc} %{ggdb:-lg}}" -+ "%{!shared: \ -+ %{!pg: \ -+ %{!pthread: %{!kthread:-lc} %{kthread:-lpthread -lc}} \ -+ %{pthread:-lc_r}} \ -+ %{pg: \ -+ %{!pthread: %{!kthread:-lc_p} %{kthread:-lpthread_p -lc_p}} \ -+ %{pthread:-lc_r_p}}}" - #else - #define LIB_SPEC \ - "%{!shared: \ diff --git a/lang/gnat/files/patch-ac b/lang/gnat/files/patch-ac index 470b37cc2421..41e4be9d9079 100644 --- a/lang/gnat/files/patch-ac +++ b/lang/gnat/files/patch-ac @@ -1,31 +1,20 @@ -*** ada/Makefile.in.orig Thu Oct 24 04:02:15 2002 ---- ada/Makefile.in Fri Nov 22 09:12:11 2002 -*************** -*** 820,825 **** ---- 820,845 ---- - endif - endif - -+ ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),) -+ LIBGNAT_TARGET_PAIRS = \ -+ a-intnam.ads<4fintnam.ads \ -+ s-inmaop.adb<7sinmaop.adb \ -+ s-intman.adb<5fintman.adb \ -+ s-mastop.adb<5omastop.adb \ -+ s-osinte.adb<5fosinte.adb \ -+ s-osinte.ads<5fosinte.ads \ -+ s-osprim.adb<7sosprim.adb \ -+ s-taprop.adb<5ftaprop.adb \ -+ s-taspri.ads<7staspri.ads \ -+ s-tpopsp.adb<7stpopsp.adb \ -+ system.ads<5fsystem.ads -+ -+ SHARED_MAJOR = 1 -+ soext = .so.$(SHARED_MAJOR) -+ THREADSLIB=-pthread -+ LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/')) -+ endif -+ - ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),) - ifeq ($(strip $(filter-out mips sgi irix6%,$(targ))),) - LIBGNAT_TARGET_PAIRS = \ +--- gcc/ada/Makefile.in.orig Tue May 17 09:22:45 2005 ++++ gcc/ada/Makefile.in Mon Nov 28 10:24:38 2005 +@@ -893,7 +893,7 @@ + mlib-tgt.adb<mlib-tgt-linux.adb + GNATLIB_SHARED = gnatlib-shared-dual + +- THREADSLIB= -lc_r ++ THREADSLIB= $(PTHREAD_LIBS) + GMEM_LIB = gmemlib + PREFIX_OBJS = $(PREFIX_REAL_OBJS) + LIBRARY_VERSION := $(LIB_VERSION) +@@ -1410,7 +1410,7 @@ + # subdirectory and copied. + LIBGNAT_SRCS = ada.h adaint.c adaint.h argv.c cio.c cstreams.c \ + errno.c exit.c cal.c ctrl_c.c \ +- raise.h raise.c sysdep.c aux-io.c init.c initialize.c seh_init.c \ ++ raise.h raise.c sysdep.c aux-io.c init.c initialize.c seh_init.c types.h \ + final.c tracebak.c tb-alvms.c tb-alvxw.c expect.c mkdir.c socket.c gsocket.h \ + $(EXTRA_LIBGNAT_SRCS) + diff --git a/lang/gnat/files/patch-ad b/lang/gnat/files/patch-ad index df9243d0c8a5..7ce6e14ae457 100644 --- a/lang/gnat/files/patch-ad +++ b/lang/gnat/files/patch-ad @@ -1,19 +1,11 @@ -*** ./ada/make.adb.orig Fri Sep 24 08:41:53 1999 ---- ./ada/make.adb Tue Nov 2 02:46:10 1999 -*************** -*** 238,244 **** - -- Compiler, Binder & Linker Data and Subprograms -- - ---------------------------------------------------- - -! Gcc : String_Access := Program_Name ("gcc"); - Gnatbind : String_Access := Program_Name ("gnatbind"); - Gnatlink : String_Access := Program_Name ("gnatlink"); - -- Default compiler, binder, linker programs ---- 238,244 ---- - -- Compiler, Binder & Linker Data and Subprograms -- - ---------------------------------------------------- - -! Gcc : String_Access := Program_Name ("adagcc"); - Gnatbind : String_Access := Program_Name ("gnatbind"); - Gnatlink : String_Access := Program_Name ("gnatlink"); - -- Default compiler, binder, linker programs +--- gcc/ada/make.adb.orig Fri Jul 29 09:03:47 2005 ++++ gcc/ada/make.adb Wed Nov 23 23:36:44 2005 +@@ -579,7 +579,7 @@ + -- Compiler, Binder & Linker Data and Subprograms -- + ---------------------------------------------------- + +- Gcc : String_Access := Program_Name ("gcc"); ++ Gcc : String_Access := Program_Name ("gnatgcc"); + Gnatbind : String_Access := Program_Name ("gnatbind"); + Gnatlink : String_Access := Program_Name ("gnatlink"); + -- Default compiler, binder, linker programs diff --git a/lang/gnat/files/patch-ae b/lang/gnat/files/patch-ae deleted file mode 100644 index 728b752cddf4..000000000000 --- a/lang/gnat/files/patch-ae +++ /dev/null @@ -1,19 +0,0 @@ -*** ./ada/gnatcmd.adb.orig Thu Oct 24 04:02:18 2002 ---- ./ada/gnatcmd.adb Fri Nov 22 09:16:30 2002 -*************** -*** 2530,2536 **** - Usage => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt" - & "files] /qualifiers"), - VMS_Only => True, -! Unixcmd => new S'("gcc"), - Unixsws => new Argument_List'(new String'("-shared") - & Init_Object_Dirs), - Switches => Shared_Switches'Access, ---- 2530,2536 ---- - Usage => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt" - & "files] /qualifiers"), - VMS_Only => True, -! Unixcmd => new S'("adagcc"), - Unixsws => new Argument_List'(new String'("-shared") - & Init_Object_Dirs), - Switches => Shared_Switches'Access, diff --git a/lang/gnat/files/patch-af b/lang/gnat/files/patch-af index 743bf477ec07..2219250b6ff3 100644 --- a/lang/gnat/files/patch-af +++ b/lang/gnat/files/patch-af @@ -1,19 +1,11 @@ -*** ./ada/gnatlink.adb.orig Fri Sep 24 08:41:46 1999 ---- ./ada/gnatlink.adb Tue Nov 2 02:46:20 1999 -*************** -*** 97,103 **** - -- This table collects the arguments to be passed to compile the binder - -- generated file. - -! Gcc : String_Access := Program_Name ("gcc"); - - Read_Mode : constant String := "r" & Ascii.Nul; - ---- 97,103 ---- - -- This table collects the arguments to be passed to compile the binder - -- generated file. - -! Gcc : String_Access := Program_Name ("adagcc"); - - Read_Mode : constant String := "r" & Ascii.Nul; - +--- gcc/ada/gnatlink.adb.orig Fri Jul 29 09:03:45 2005 ++++ gcc/ada/gnatlink.adb Wed Nov 23 23:38:40 2005 +@@ -123,7 +123,7 @@ + -- This table collects the arguments to be passed to compile the binder + -- generated file. + +- Gcc : String_Access := Program_Name ("gcc"); ++ Gcc : String_Access := Program_Name ("gnatgcc"); + + Read_Mode : constant String := "r" & ASCII.Nul; + diff --git a/lang/gnat/files/patch-ag b/lang/gnat/files/patch-ag index 4bc89fcccd5c..26e672ab9114 100644 --- a/lang/gnat/files/patch-ag +++ b/lang/gnat/files/patch-ag @@ -1,19 +1,11 @@ -*** ./ada/gnatchop.adb.orig Thu Oct 24 04:02:18 2002 ---- ./ada/gnatchop.adb Fri Nov 22 09:18:03 2002 -*************** -*** 49,55 **** - Config_File_Name : constant String_Access := new String'("gnat.adc"); - -- The name of the file holding the GNAT configuration pragmas - -! Gcc : String_Access := new String'("gcc"); - -- May be modified by switch --GCC= - - Gcc_Set : Boolean := False; ---- 49,55 ---- - Config_File_Name : constant String_Access := new String'("gnat.adc"); - -- The name of the file holding the GNAT configuration pragmas - -! Gcc : String_Access := new String'("adagcc"); - -- May be modified by switch --GCC= - - Gcc_Set : Boolean := False; +--- gcc/ada/gnatchop.adb.orig Fri Jul 29 09:03:44 2005 ++++ gcc/ada/gnatchop.adb Wed Nov 23 23:40:15 2005 +@@ -45,7 +45,7 @@ + Config_File_Name : constant String_Access := new String'("gnat.adc"); + -- The name of the file holding the GNAT configuration pragmas + +- Gcc : String_Access := new String'("gcc"); ++ Gcc : String_Access := new String'("gnatgcc"); + -- May be modified by switch --GCC= + + Gcc_Set : Boolean := False; diff --git a/lang/gnat/files/patch-ah b/lang/gnat/files/patch-ah deleted file mode 100644 index 1cfe0c40d75b..000000000000 --- a/lang/gnat/files/patch-ah +++ /dev/null @@ -1,11 +0,0 @@ ---- ada/a-cstrea.c.orig Fri Feb 1 22:59:35 2002 -+++ ada/a-cstrea.c Fri Feb 1 23:03:11 2002 -@@ -205,7 +205,7 @@ - #elif defined (MSDOS) - _fixpath (nam, buffer); - --#elif defined (sgi) -+#elif defined (sgi) || defined (__FreeBSD__) - - /* Use realpath function which resolves links and references to .. and .. - on those Unix systems that support it. Note that linux provides it but diff --git a/lang/gnat/files/patch-ai b/lang/gnat/files/patch-ai deleted file mode 100644 index 4f9c35e206c3..000000000000 --- a/lang/gnat/files/patch-ai +++ /dev/null @@ -1,110 +0,0 @@ -*** ada/a-init.c.orig Wed Jul 19 15:09:57 2000 ---- ada/a-init.c Fri Oct 13 11:25:52 2000 -*************** -*** 1441,1446 **** ---- 1441,1528 ---- - } - - -+ /*************************************************/ -+ /* __gnat_initialize (FreeBSD version) */ -+ /*************************************************/ -+ -+ #elif defined (__FreeBSD__) -+ -+ #include <signal.h> -+ #include <unistd.h> -+ -+ static void -+ __gnat_error_handler (sig, code, sc) -+ int sig; -+ int code; -+ struct sigcontext *sc; -+ { -+ struct Exception_Data *exception; -+ char *msg; -+ -+ switch (sig) -+ { -+ case SIGFPE: -+ exception = &constraint_error; -+ msg = "SIGFPE"; -+ break; -+ -+ case SIGILL: -+ exception = &constraint_error; -+ msg = "SIGILL"; -+ break; -+ -+ case SIGSEGV: -+ exception = &storage_error; -+ msg = "stack overflow or erroneous memory access"; -+ break; -+ -+ case SIGBUS: -+ exception = &constraint_error; -+ msg = "SIGBUS"; -+ break; -+ -+ default: -+ exception = &program_error; -+ msg = "unhandled signal"; -+ } -+ -+ Raise_From_Signal_Handler (exception, msg); -+ } -+ -+ void -+ __gnat_install_handler () -+ { -+ struct sigaction act; -+ -+ /* Set up signal handler to map synchronous signals to appropriate -+ exceptions. Make sure that the handler isn't interrupted by another -+ signal that might cause a scheduling event! */ -+ -+ act.sa_handler = __gnat_error_handler; -+ act.sa_flags = SA_NODEFER | SA_RESTART; -+ (void) sigemptyset (&act.sa_mask); -+ -+ (void) sigaction (SIGILL, &act, NULL); -+ (void) sigaction (SIGFPE, &act, NULL); -+ (void) sigaction (SIGSEGV, &act, NULL); -+ (void) sigaction (SIGBUS, &act, NULL); -+ } -+ -+ void __gnat_init_float (); -+ -+ void -+ __gnat_initialize () -+ { -+ __gnat_install_handler (); -+ -+ /* XXX - Initialize floating-point coprocessor. This call is -+ needed because FreeBSD defaults to 64-bit precision instead -+ of 80-bit precision? We require the full precision for -+ proper operation, given that we have set Max_Digits etc -+ with this in mind */ -+ __gnat_init_float (); -+ } -+ - /***************************************/ - /* __gnat_initialize (default version) */ - /***************************************/ -*************** -*** 1466,1472 **** - WIN32 and could be used under OS/2 */ - - #if defined (_WIN32) || defined (__INTERIX) || defined (__EMX__) \ -! || defined (__Lynx__) - - #define HAVE_GNAT_INIT_FLOAT - ---- 1548,1554 ---- - WIN32 and could be used under OS/2 */ - - #if defined (_WIN32) || defined (__INTERIX) || defined (__EMX__) \ -! || defined (__Lynx__) || defined (__FreeBSD__) - - #define HAVE_GNAT_INIT_FLOAT - diff --git a/lang/gnat/files/patch-aj b/lang/gnat/files/patch-aj deleted file mode 100644 index 564a9ec5cce5..000000000000 --- a/lang/gnat/files/patch-aj +++ /dev/null @@ -1,54 +0,0 @@ -*** ada/a-sysdep.c.orig Thu Oct 24 04:02:16 2002 ---- ada/a-sysdep.c Fri Nov 22 09:24:51 2002 -*************** -*** 286,292 **** - #if defined (linux) || defined (sun) || defined (sgi) || defined (__EMX__) \ - || (defined (__osf__) && ! defined (__alpha_vxworks)) || defined (WINNT) \ - || defined (__MACHTEN__) || defined (hpux) || defined (_AIX) \ -! || (defined (__svr4__) && defined (i386)) || defined (__Lynx__) - #include <termios.h> - #elif defined (VMS) - extern char *decc$ga_stdscr; ---- 286,293 ---- - #if defined (linux) || defined (sun) || defined (sgi) || defined (__EMX__) \ - || (defined (__osf__) && ! defined (__alpha_vxworks)) || defined (WINNT) \ - || defined (__MACHTEN__) || defined (hpux) || defined (_AIX) \ -! || (defined (__svr4__) && defined (i386)) || defined (__Lynx__) \ -! || defined (__FreeBSD__) - #include <termios.h> - #elif defined (VMS) - extern char *decc$ga_stdscr; -*************** -*** 336,342 **** - || (defined (__osf__) && ! defined (__alpha_vxworks)) \ - || defined (__CYGWIN32__) || defined (__MACHTEN__) || defined (hpux) \ - || defined (_AIX) || (defined (__svr4__) && defined (i386)) \ -! || defined (__Lynx__) - char c; - int nread; - int good_one = 0; ---- 337,343 ---- - || (defined (__osf__) && ! defined (__alpha_vxworks)) \ - || defined (__CYGWIN32__) || defined (__MACHTEN__) || defined (hpux) \ - || defined (_AIX) || (defined (__svr4__) && defined (i386)) \ -! || defined (__Lynx__) || defined (__FreeBSD__) - char c; - int nread; - int good_one = 0; -*************** -*** 355,361 **** - #if defined(linux) || defined (sun) || defined (sgi) || defined (__EMX__) \ - || defined (__osf__) || defined (__MACHTEN__) || defined (hpux) \ - || defined (_AIX) || (defined (__svr4__) && defined (i386)) \ -! || defined (__Lynx__) - eof_ch = termios_rec.c_cc[VEOF]; - - /* If waiting (i.e. Get_Immediate (Char)), set MIN = 1 and wait for ---- 356,362 ---- - #if defined(linux) || defined (sun) || defined (sgi) || defined (__EMX__) \ - || defined (__osf__) || defined (__MACHTEN__) || defined (hpux) \ - || defined (_AIX) || (defined (__svr4__) && defined (i386)) \ -! || defined (__Lynx__) || defined (__FreeBSD__) - eof_ch = termios_rec.c_cc[VEOF]; - - /* If waiting (i.e. Get_Immediate (Char)), set MIN = 1 and wait for diff --git a/lang/gnat/files/patch-ak b/lang/gnat/files/patch-ak deleted file mode 100644 index 1f77b68763c2..000000000000 --- a/lang/gnat/files/patch-ak +++ /dev/null @@ -1,30 +0,0 @@ -*** ada/i-cstrea.ads Fri Sep 24 08:42:41 1999 ---- ada/i-cstrea.ads Sat Nov 6 10:20:43 1999 -*************** -*** 184,190 **** - size : size_t) - return int; - -! procedure tmpnam (string : chars); - -- The parameter must be a pointer to a string buffer of at least L_tmpnam - -- bytes (the call with a null parameter is not supported). The returned - -- value, which is just a copy of the input argument, is discarded. ---- 184,190 ---- - size : size_t) - return int; - -! procedure tmpnam (tname : chars); - -- The parameter must be a pointer to a string buffer of at least L_tmpnam - -- bytes (the call with a null parameter is not supported). The returned - -- value, which is just a copy of the input argument, is discarded. -*************** -*** 265,272 **** - pragma Import (C, isatty); - pragma Import (C, mktemp); - pragma Import (C, rewind); -- pragma Import (C, tmpnam); -- pragma Import (C, tmpfile); - pragma Import (C, ungetc); - pragma Import (C, unlink); - ---- 265,270 ---- diff --git a/lang/gnat/files/patch-al b/lang/gnat/files/patch-al deleted file mode 100644 index fb2b6b81638d..000000000000 --- a/lang/gnat/files/patch-al +++ /dev/null @@ -1,34 +0,0 @@ -*** ada/i-cstrea.adb Fri Sep 24 08:42:42 1999 ---- ada/i-cstrea.adb Sat Nov 6 18:33:57 1999 -*************** -*** 108,111 **** ---- 108,136 ---- - return C_setvbuf (stream, buffer, mode, size); - end setvbuf; - -+ procedure strcpy (dst : chars; src : chars); -+ pragma Import (C, strcpy); -+ -+ function C_mktemp (template : chars) return chars; -+ pragma Import (C, C_mktemp, "mktemp"); -+ -+ procedure tmpnam (tname : chars) is -+ use type System.Address; -+ Template : String (1 .. 18) := "/var/tmp/tmp.XXXX" & ASCII.Nul; -+ Name : chars; -+ begin -+ Name := C_mktemp (Template'Address); -+ if Name /= System.Null_Address then -+ strcpy (tname'Address, Name); -+ end if; -+ end tmpnam; -+ -+ function tmpfile return FILEs is -+ Name : String (1 .. L_tmpnam) := (others => ASCII.Nul); -+ Mode : String (1 .. 3) := "w+" & ASCII.Nul; -+ begin -+ tmpnam (Name'Address); -+ return (fopen (Name'Address, Mode'Address)); -+ end tmpfile; -+ - end Interfaces.C_Streams; diff --git a/lang/gnat/files/patch-an b/lang/gnat/files/patch-an deleted file mode 100644 index 1ef1098cdb6e..000000000000 --- a/lang/gnat/files/patch-an +++ /dev/null @@ -1,18 +0,0 @@ ---- ada/a-link.c.orig Sat May 6 19:38:57 2000 -+++ ada/a-link.c Sat May 6 19:41:09 2000 -@@ -149,6 +149,15 @@ - unsigned char objlist_file_supported = 0; - unsigned char using_gnu_linker = 0; - -+#elif defined (__FreeBSD__) -+char *object_file_option = ""; -+char *run_path_option = ""; -+char shared_libgnat_default = SHARED; -+int link_max = 2147483647; -+unsigned char objlist_file_supported = 0; -+unsigned char using_gnu_linker = 0; -+char *object_library_extension = ".a"; -+ - #elif defined (linux) - char *object_file_option = ""; - char *run_path_option = "-Wl,-rpath,"; diff --git a/lang/gnat/files/patch-ao b/lang/gnat/files/patch-ao deleted file mode 100644 index 3391b525a05e..000000000000 --- a/lang/gnat/files/patch-ao +++ /dev/null @@ -1,29 +0,0 @@ ---- ../gnat-3.15p-src/examples/Makefile Tue Jan 30 18:00:05 2001 -+++ ../gnat-3.15p-src/examples/Makefile.new Mon Feb 4 15:01:55 2002 -@@ -6,10 +6,10 @@ - CC = gcc - - # the Ada Compiler --ADAC = $(CC) -+ADAC = adagcc - - # the C++ compiler --CPLUSPLUS = c++ -+CPLUSPLUS = g++ - - # Gnat1 compilation flags - GF = -O2 -@@ -32,9 +32,10 @@ - demo1$e \ - demo2$e \ - test_cl$e \ -- diners$e \ -- ex6_main \ -- cpp_main -+ diners$e -+# \ C++ not built into FreeBSD GNAT -+# ex6_main$e \ -+# cpp_main$e - - - #----------------------------------------------------------------------------- diff --git a/lang/gnat/files/patch-ap b/lang/gnat/files/patch-ap deleted file mode 100644 index 9474e433c9ef..000000000000 --- a/lang/gnat/files/patch-ap +++ /dev/null @@ -1,30 +0,0 @@ -*** ada/a-adaint.c.orig Thu Oct 24 04:02:15 2002 ---- ada/a-adaint.c Fri Nov 22 09:53:21 2002 -*************** -*** 605,610 **** ---- 605,612 ---- - - #if defined (linux) && !defined (__vxworks) - return mkstemp (path); -+ #elif defined (__FreeBSD__) -+ return mkstemp (path); - #elif defined (__Lynx__) - mktemp (path); - #else -*************** -*** 673,679 **** - - free (pname); - } -! #elif defined (linux) - char *tmpdir = getenv ("TMPDIR"); - - if (tmpdir == NULL) ---- 675,681 ---- - - free (pname); - } -! #elif defined (linux) || defined (__FreeBSD__) - char *tmpdir = getenv ("TMPDIR"); - - if (tmpdir == NULL) diff --git a/lang/gnat/files/prj-attr-pm.adb b/lang/gnat/files/prj-attr-pm.adb new file mode 100644 index 000000000000..21bd566f82f2 --- /dev/null +++ b/lang/gnat/files/prj-attr-pm.adb @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . A T T R . P M -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 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- -- +-- 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, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Prj.Attr.PM is + + ------------------- + -- Add_Attribute -- + ------------------- + + procedure Add_Attribute + (To_Package : Package_Node_Id; + Attribute_Name : Name_Id; + Attribute_Node : out Attribute_Node_Id) + is + begin + -- Only add the attribute if the package is already defined + + if To_Package /= Empty_Package then + Attrs.Increment_Last; + Attrs.Table (Attrs.Last) := + (Name => Attribute_Name, + Var_Kind => Undefined, + Optional_Index => False, + Attr_Kind => Unknown, + Next => + Package_Attributes.Table (To_Package.Value).First_Attribute); + Package_Attributes.Table (To_Package.Value).First_Attribute := + Attrs.Last; + Attribute_Node := (Value => Attrs.Last); + end if; + end Add_Attribute; + + ------------------------- + -- Add_Unknown_Package -- + ------------------------- + + procedure Add_Unknown_Package (Name : Name_Id; Id : out Package_Node_Id) is + begin + Package_Attributes.Increment_Last; + Id := (Value => Package_Attributes.Last); + Package_Attributes.Table (Id.Value) := + (Name => Name, Known => False, First_Attribute => Empty_Attr); + end Add_Unknown_Package; + +end Prj.Attr.PM; diff --git a/lang/gnat/files/prj-attr-pm.ads b/lang/gnat/files/prj-attr-pm.ads new file mode 100644 index 000000000000..36ad40f70522 --- /dev/null +++ b/lang/gnat/files/prj-attr-pm.ads @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . A T T R . P M -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2005, 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- -- +-- 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, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains insecure procedures that are intended to be used +-- only inside the Prj and MLib hierarchies. It should not be imported by +-- other tools, such as GPS. + +package Prj.Attr.PM is + + -- The following procedures are not secure and should only be used by the + -- Project Manager, that is the packages of the Prj or MLib hierarchies. + -- What does "not secure" mean??? + + procedure Add_Unknown_Package (Name : Name_Id; Id : out Package_Node_Id); + -- Add a new unknown package. The Name cannot be the name of a predefined + -- or already registered package, but this is not checked. + + procedure Add_Attribute + (To_Package : Package_Node_Id; + Attribute_Name : Name_Id; + Attribute_Node : out Attribute_Node_Id); + -- Add an attribute to the list for package To_Package. Attribute_Name + -- cannot be the name of an existing attribute of the package, but this is + -- not checked. Does nothing if To_Package is Empty_Package. + +end Prj.Attr.PM; diff --git a/lang/gnat/files/5fosinte.adb b/lang/gnat/files/s-osinte-freebsd.adb index 8d28fda71933..d7a528aa4b48 100644 --- a/lang/gnat/files/5fosinte.adb +++ b/lang/gnat/files/s-osinte-freebsd.adb @@ -1,15 +1,12 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- -- S Y S T E M . O S _ I N T E R F A C E -- -- -- -- B o d y -- --- (Version for new GNARL) -- -- -- --- $Revision: 1.2 $ -- --- -- --- Copyright (C) 1991,1992,1993,1994,1995,1996 Florida State University -- +-- Copyright (C) 1991-2005 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- -- @@ -19,8 +16,8 @@ -- 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 GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, 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, -- @@ -37,44 +34,8 @@ -- This is the FreeBSD THREADS version of this package --- This is only a first approximation. --- It should be autogenerated by the m4 macro processor. --- Contributed by Daniel M. Eischen (eischen@vigrid.com) - --- DO NOT EDIT this file. --- It was automatically generated from another file by the m4 macro processor. --- The name of the file you should edit is the same as this one, but with --- ".ads" replaced by ".sm4", or --- ".adb" replaced by ".bm4", or --- ".c" replaced by ".cm4", or --- ".dat" replaced by ".tm4" - --- Local options selected: --- __TARGET = i386-unknown-freebsd --- __ARCH = I386 --- __OS = FREEBSD --- __HAS_SIGCONTEXT = 1 --- __HAS_UCONTEXT = 0 --- __THREADS = POSIX_THREADS --- __THREAD_VARIANT = MIT-THREADS --- __HAS_TIMESPEC = 1 --- __HAS_NANOSLEEP = 1 --- __HAS_CLOCK_GETTIME = 1 --- __HAS_GETTIMEOFDAY = 1 --- __POSIX_THREAD_PRIO_PROTECT = 0 --- __POSIX_THREAD_PRIO_INHERIT = 0 --- __POSIX_THREAD_ATTR_STACKADDR = 1 --- __POSIX_THREAD_ATTR_STACKSIZE = 1 --- __POSIX_THREAD_PRIORITY_SCHEDULING = 0 - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - --- This version is for POSIX-like operating systems --- The original file "s-osinte.ads_m4" contains conditional --- macro calls that allow selection of various options. - with Interfaces.C; use Interfaces.C; + package body System.OS_Interface is function Errno return int is @@ -87,6 +48,7 @@ package body System.OS_Interface is end Errno; function Get_Stack_Base (thread : pthread_t) return Address is + pragma Unreferenced (thread); begin return (0); end Get_Stack_Base; @@ -119,11 +81,10 @@ package body System.OS_Interface is -- If F has negative value due to a round-up, adjust for positive F -- value. if F < 0.0 then S := S - 1; F := F + 1.0; end if; - return timespec' (ts_sec => S, + return timespec'(ts_sec => S, ts_nsec => long (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; - function To_Duration (TV : struct_timeval) return Duration is begin return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; @@ -139,7 +100,7 @@ package body System.OS_Interface is -- If F has negative value due to a round-up, adjust for positive F -- value. if F < 0.0 then S := S - 1; F := F + 1.0; end if; - return struct_timeval' (tv_sec => S, + return struct_timeval'(tv_sec => S, tv_usec => long (Long_Long_Integer (F * 10#1#E6))); end To_Timeval; diff --git a/lang/gnat/files/5fosinte.ads b/lang/gnat/files/s-osinte-freebsd.ads index b4bb2c9853e3..81a918656451 100644 --- a/lang/gnat/files/5fosinte.ads +++ b/lang/gnat/files/s-osinte-freebsd.ads @@ -1,15 +1,13 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- -- S Y S T E M . O S _ I N T E R F A C E -- -- -- -- S p e c -- --- (Version for new GNARL) -- -- -- --- $Revision: 1.5 $ -- --- -- --- Copyright (C) 1991,92,93,94,95,1996 Free Software Foundation, Inc. -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2005, 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- -- @@ -19,8 +17,8 @@ -- 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 GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, 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, -- @@ -37,53 +35,15 @@ -- This is the FreeBSD PTHREADS version of this package --- This is only a first approximation. --- It should be autogenerated by the m4 macro processor. --- Contributed by Daniel Eischen (eischen@vigrid.com) - --- DO NOT EDIT this file. --- It was automatically generated from another file by the m4 macro processor. --- The name of the file you should edit is the same as this one, but with --- ".ads" replaced by ".sm4", or --- ".adb" replaced by ".bm4", or --- ".c" replaced by ".cm4", or --- ".dat" replaced by ".tm4" - --- Local options selected: --- __TARGET = i386-unknown-freebsd --- __ARCH = I386 --- __OS = FREEBSD --- __HAS_SIGCONTEXT = 1 --- __HAS_UCONTEXT = 1 --- __THREADS = POSIX_THREADS --- __THREAD_VARIANT = ?? --- __HAS_TIMESPEC = 1 --- __HAS_NANOSLEEP = 1 --- __HAS_CLOCK_GETTIME = 1 --- __HAS_GETTIMEOFDAY = 1 --- __POSIX_THREAD_PRIO_PROTECT = 1 --- __POSIX_THREAD_PRIO_INHERIT = 1 --- __POSIX_THREAD_ATTR_STACKADDR = 1 --- __POSIX_THREAD_ATTR_STACKSIZE = 1 --- __POSIX_THREAD_PRIORITY_SCHEDULING = 1 - -- This package encapsulates all direct interfaces to OS services -- that are needed by children of System. --- PLEASE DO NOT add any with-clauses to this package --- or remove the pragma Elaborate_Body. --- It is designed to be a bottom-level (leaf) package. - --- This version is for POSIX-like operating systems --- The original file "s-osinte.sm4" contains conditional --- macro calls that allow selection of various options. --- The options selected for this expansion were: - --- When adding new signals to s-osinte.sm4, don't forget to update --- cconst.dat (m4 macro definition data-file) and the files --- s-intnam.ads (package Ada.Interrupt_Names) for the various ports. +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Interfaces.C; +with Unchecked_Conversion; + package System.OS_Interface is pragma Preelaborate; @@ -106,47 +66,11 @@ package System.OS_Interface is function Errno return int; pragma Inline (Errno); - -- NAMEs not used are commented-out - -- NAMEs not supported on this system have __NAME for value - - -- E2BIG : constant := 7; - -- EACCES : constant := 13; EAGAIN : constant := 35; - -- EBADF : constant := 9; - -- EBUSY : constant := 16; - -- ECHILD : constant := 10; - -- EDEADLK : constant := 11; - -- EDOM : constant := 33; - -- EEXIST : constant := 17; - -- EFAULT : constant := 14; - -- EFBIG : constant := 27; EINTR : constant := 4; EINVAL : constant := 22; - -- EIO : constant := 5; - -- EISDIR : constant := 21; - -- EMFILE : constant := 24; - -- EMLINK : constant := 31; - -- ENAMETOOLONG : constant := 63; - -- ENFILE : constant := 23; - -- ENODEV : constant := 19; - -- ENOENT : constant := 2; - -- ENOEXEC : constant := 8; - -- ENOLCK : constant := 37; ENOMEM : constant := 12; - -- ENOSPC : constant := 28; - -- ENOSYS : constant := 78; - -- ENOTDIR : constant := 20; - -- ENOTEMPTY : constant := 66; - -- ENOTTY : constant := 25; - -- ENXIO : constant := 6; - -- EPERM : constant := 1; - -- EPIPE : constant := 32; - -- ERANGE : constant := 34; - -- EROFS : constant := 30; - -- ESPIPE : constant := 29; - -- ESRCH : constant := 3; ETIMEDOUT : constant := 60; - -- EXDEV : constant := 18; ------------- -- Signals -- @@ -156,9 +80,6 @@ package System.OS_Interface is type Signal is new int range 0 .. Max_Interrupt; for Signal'Size use int'Size; - -- NAMEs not used are commented-out - -- NAMEs not supported on this system have __NAME for value - SIGHUP : constant := 1; -- hangup SIGINT : constant := 2; -- interrupt (rubout) SIGQUIT : constant := 3; -- quit (ASCD FS) @@ -211,16 +132,22 @@ package System.OS_Interface is type sigset_t is private; - function sigaddset (set : access sigset_t; sig : Signal) return int; + function sigaddset + (set : access sigset_t; + sig : Signal) return int; pragma Import (C, sigaddset, "sigaddset"); - function sigdelset (set : access sigset_t; sig : Signal) return int; + function sigdelset + (set : access sigset_t; + sig : Signal) return int; pragma Import (C, sigdelset, "sigdelset"); function sigfillset (set : access sigset_t) return int; pragma Import (C, sigfillset, "sigfillset"); - function sigismember (set : access sigset_t; sig : Signal) return int; + function sigismember + (set : access sigset_t; + sig : Signal) return int; pragma Import (C, sigismember, "sigismember"); function sigemptyset (set : access sigset_t) return int; @@ -230,42 +157,35 @@ package System.OS_Interface is type struct_sigcontext is private; type old_struct_sigaction is record - sa_handler : System.Address; - sa_mask : sigset_t; - sa_flags : int; + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; end record; pragma Convention (C, old_struct_sigaction); type new_struct_sigaction is record - sa_handler : System.Address; - sa_flags : int; - sa_mask : sigset_t; + sa_handler : System.Address; + sa_flags : int; + sa_mask : sigset_t; end record; pragma Convention (C, new_struct_sigaction); subtype struct_sigaction is new_struct_sigaction; type struct_sigaction_ptr is access all struct_sigaction; - SIG_BLOCK : constant := 1; SIG_UNBLOCK : constant := 2; SIG_SETMASK : constant := 3; - -- SA_NOCLDSTOP : constant := 8; - -- not used - -- SA_SIGINFO : constant := __SA_SIGINFO; - -- not used - SIG_DFL : constant := 0; SIG_IGN : constant := 1; - -- SIG_ERR : constatn := -1; - -- not used + + SA_SIGINFO : constant := 16#0040#; function sigaction (sig : Signal; act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) - return int; + oact : struct_sigaction_ptr) return int; pragma Import (C, sigaction, "sigaction"); ---------- @@ -297,8 +217,8 @@ package System.OS_Interface is pragma Inline (To_Timespec); type struct_timezone is record - tz_minuteswest : int; - tz_dsttime : int; + tz_minuteswest : int; + tz_dsttime : int; end record; pragma Convention (C, struct_timezone); type struct_timeval is private; @@ -319,8 +239,6 @@ package System.OS_Interface is procedure usleep (useconds : unsigned_long); pragma Import (C, usleep, "usleep"); - -- add a hook to locate the Epoch, for use with Calendar???? - ------------------------- -- Priority Scheduling -- ------------------------- @@ -337,10 +255,7 @@ package System.OS_Interface is Self_PID : constant pid_t; - function kill - (pid : pid_t; - sig : Signal) - return int; + function kill (pid : pid_t; sig : Signal) return int; pragma Import (C, kill, "kill"); function getpid return pid_t; @@ -363,6 +278,8 @@ package System.OS_Interface is type Thread_Body is access function (arg : System.Address) return System.Address; + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); type pthread_t is private; subtype Thread_Id is pthread_t; @@ -411,29 +328,29 @@ package System.OS_Interface is (addr : Address; len : size_t; prot : int) return int; pragma Import (C, mprotect); - ----------------------------------------- - -- Nonstandard Thread Initialization -- - ----------------------------------------- - -- FSU_THREADS requires pthread_init, which is nonstandard - -- and this should be invoked during the elaboration of s-taprop.adb - -- - -- FreeBSD does not require this so we provide an empty Ada body. + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + -- FSU_THREADS requires pthread_init, which is nonstandard and + -- this should be invoked during the elaboration of s-taprop.adb + + -- FreeBSD does not require this so we provide an empty Ada body + procedure pthread_init; - --------------------------- - -- POSIX.1c Section 3 -- - --------------------------- + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- function sigwait (set : access sigset_t; - sig : access Signal) - return int; + sig : access Signal) return int; pragma Import (C, sigwait, "sigwait"); function pthread_kill (thread : pthread_t; - sig : Signal) - return int; + sig : Signal) return int; pragma Import (C, pthread_kill, "pthread_kill"); type sigset_t_ptr is access all sigset_t; @@ -441,90 +358,71 @@ package System.OS_Interface is function pthread_sigmask (how : int; set : sigset_t_ptr; - oset : sigset_t_ptr) - return int; + oset : sigset_t_ptr) return int; pragma Import (C, pthread_sigmask, "pthread_sigmask"); - ---------------------------- - -- POSIX.1c Section 11 -- - ---------------------------- + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) - return int; + (attr : access pthread_mutexattr_t) return int; pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) - return int; + (attr : access pthread_mutexattr_t) return int; pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); function pthread_mutex_init (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) - return int; + attr : access pthread_mutexattr_t) return int; pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); - function pthread_mutex_destroy - (mutex : access pthread_mutex_t) - return int; + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); - function pthread_mutex_lock - (mutex : access pthread_mutex_t) - return int; + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); - function pthread_mutex_unlock - (mutex : access pthread_mutex_t) - return int; + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); function pthread_condattr_init - (attr : access pthread_condattr_t) - return int; + (attr : access pthread_condattr_t) return int; pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); function pthread_condattr_destroy - (attr : access pthread_condattr_t) - return int; + (attr : access pthread_condattr_t) return int; pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); function pthread_cond_init (cond : access pthread_cond_t; - attr : access pthread_condattr_t) - return int; + attr : access pthread_condattr_t) return int; pragma Import (C, pthread_cond_init, "pthread_cond_init"); - function pthread_cond_destroy - (cond : access pthread_cond_t) - return int; + function pthread_cond_destroy (cond : access pthread_cond_t) return int; pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); - function pthread_cond_signal - (cond : access pthread_cond_t) - return int; + function pthread_cond_signal (cond : access pthread_cond_t) return int; pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); function pthread_cond_wait (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) - return int; + mutex : access pthread_mutex_t) return int; pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); function pthread_cond_timedwait (cond : access pthread_cond_t; mutex : access pthread_mutex_t; - abstime : access timespec) - return int; + abstime : access timespec) return int; pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); Relative_Timed_Wait : constant Boolean := False; -- pthread_cond_timedwait requires an absolute delay time - ---------------------------- - -- POSIX.1c Section 13 -- - ---------------------------- + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- PTHREAD_PRIO_NONE : constant := 0; PTHREAD_PRIO_PROTECT : constant := 2; @@ -532,30 +430,26 @@ package System.OS_Interface is function pthread_mutexattr_setprotocol (attr : access pthread_mutexattr_t; - protocol : int) - return int; + protocol : int) return int; pragma Import (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol"); function pthread_mutexattr_getprotocol (attr : access pthread_mutexattr_t; - protocol : access int) - return int; + protocol : access int) return int; pragma Import (C, pthread_mutexattr_getprotocol, "pthread_mutexattr_getprotocol"); function pthread_mutexattr_setprioceiling (attr : access pthread_mutexattr_t; - prioceiling : int) - return int; + prioceiling : int) return int; pragma Import (C, pthread_mutexattr_setprioceiling, "pthread_mutexattr_setprioceiling"); function pthread_mutexattr_getprioceiling (attr : access pthread_mutexattr_t; - prioceiling : access int) - return int; + prioceiling : access int) return int; pragma Import (C, pthread_mutexattr_getprioceiling, "pthread_mutexattr_getprioceiling"); @@ -568,111 +462,94 @@ package System.OS_Interface is function pthread_getschedparam (thread : pthread_t; policy : access int; - param : access struct_sched_param) - return int; + param : access struct_sched_param) return int; pragma Import (C, pthread_getschedparam, "pthread_getschedparam"); function pthread_setschedparam (thread : pthread_t; policy : int; - param : access struct_sched_param) - return int; + param : access struct_sched_param) return int; pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); function pthread_attr_setscope (attr : access pthread_attr_t; - contentionscope : int) - return int; + contentionscope : int) return int; pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); function pthread_attr_getscope (attr : access pthread_attr_t; - contentionscope : access int) - return int; + contentionscope : access int) return int; pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope"); function pthread_attr_setinheritsched (attr : access pthread_attr_t; - inheritsched : int) - return int; + inheritsched : int) return int; pragma Import (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched"); function pthread_attr_getinheritsched (attr : access pthread_attr_t; - inheritsched : access int) - return int; + inheritsched : access int) return int; pragma Import (C, pthread_attr_getinheritsched, "pthread_attr_getinheritsched"); function pthread_attr_setschedpolicy (attr : access pthread_attr_t; - policy : int) - return int; + policy : int) return int; pragma Import (C, pthread_attr_setschedpolicy, "pthread_attr_setschedpolicy"); function pthread_attr_getschedpolicy (attr : access pthread_attr_t; - policy : access int) - return int; + policy : access int) return int; pragma Import (C, pthread_attr_getschedpolicy, "pthread_attr_getschedpolicy"); function pthread_attr_setschedparam (attr : access pthread_attr_t; - sched_param : int) - return int; + sched_param : int) return int; pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam"); function pthread_attr_getschedparam (attr : access pthread_attr_t; - sched_param : access int) - return int; + sched_param : access int) return int; pragma Import (C, pthread_attr_getschedparam, "pthread_attr_getschedparam"); function sched_yield return int; pragma Import (C, sched_yield, "pthread_yield"); - ----------------------------- - -- P1003.1c - Section 16 -- - ----------------------------- + -------------------------- + -- P1003.1c Section 16 -- + -------------------------- - function pthread_attr_init - (attributes : access pthread_attr_t) - return int; + function pthread_attr_init (attributes : access pthread_attr_t) return int; pragma Import (C, pthread_attr_init, "pthread_attr_init"); function pthread_attr_destroy - (attributes : access pthread_attr_t) - return int; + (attributes : access pthread_attr_t) return int; pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); function pthread_attr_setdetachstate (attr : access pthread_attr_t; - detachstate : int) - return int; + detachstate : int) return int; pragma Import (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate"); function pthread_attr_getdetachstate (attr : access pthread_attr_t; - detachstate : access int) - return int; + detachstate : access int) return int; pragma Import (C, pthread_attr_getdetachstate, "pthread_attr_getdetachstate"); function pthread_attr_getstacksize (attr : access pthread_attr_t; - stacksize : access size_t) - return int; + stacksize : access size_t) return int; pragma Import (C, pthread_attr_getstacksize, "pthread_attr_getstacksize"); function pthread_attr_setstacksize (attr : access pthread_attr_t; - stacksize : size_t) - return int; + stacksize : size_t) return int; pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); @@ -680,8 +557,7 @@ package System.OS_Interface is (thread : access pthread_t; attributes : access pthread_attr_t; start_routine : Thread_Body; - arg : System.Address) - return int; + arg : System.Address) return int; pragma Import (C, pthread_create, "pthread_create"); function pthread_detach (thread : pthread_t) return int; @@ -693,45 +569,35 @@ package System.OS_Interface is function pthread_self return pthread_t; pragma Import (C, pthread_self, "pthread_self"); - function pthread_equal (t1 : pthread_t; t2 : pthread_t) - return int; - -- be careful not to use "=" on thread_t! - pragma Import (C, pthread_equal, "pthread_equal"); - - ---------------------------- - -- POSIX.1c Section 17 -- - ---------------------------- + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- function pthread_setspecific (key : pthread_key_t; - value : System.Address) - return int; + value : System.Address) return int; pragma Import (C, pthread_setspecific, "pthread_setspecific"); function pthread_getspecific (key : pthread_key_t) return System.Address; pragma Import (C, pthread_getspecific, "pthread_getspecific"); - type destructor_pointer is access procedure (arg : System.Address); function pthread_key_create (key : access pthread_key_t; - destructor : destructor_pointer) - return int; + destructor : destructor_pointer) return int; pragma Import (C, pthread_key_create, "pthread_key_create"); - -------------------------------------- - -- Non-portable pthread functions -- - -------------------------------------- + ------------------------------------ + -- Non-portable Pthread Functions -- + ------------------------------------ function pthread_set_name_np (thread : pthread_t; - name : System.Address) - return int; + name : System.Address) return int; pragma Import (C, pthread_set_name_np, "pthread_set_name_np"); - private type sigset_t is array (1 .. 4) of unsigned; @@ -741,11 +607,12 @@ private -- #define sa_handler __sigaction_u._handler -- #define sa_sigaction __sigaction_u._sigaction - -- Should we add a signal_context type here ? - -- How could it be done independent of the CPU architecture ? + -- Should we add a signal_context type here ??? + -- How could it be done independent of the CPU architecture ??? -- sigcontext type is opaque, so it is architecturally neutral. -- It is always passed as an access type, so define it as an empty record -- since the contents are not used anywhere. + type struct_sigcontext is null record; pragma Convention (C, struct_sigcontext); @@ -755,8 +622,8 @@ private type time_t is new long; type timespec is record - ts_sec : time_t; - ts_nsec : long; + ts_sec : time_t; + ts_nsec : long; end record; pragma Convention (C, timespec); @@ -764,20 +631,17 @@ private CLOCK_REALTIME : constant clockid_t := 0; type struct_timeval is record - tv_sec : long; - tv_usec : long; + tv_sec : long; + tv_usec : long; end record; pragma Convention (C, struct_timeval); - type record_type_1 is null record; - pragma Convention (C, record_type_1); - - type pthread_t is access record_type_1; - type pthread_attr_t is access record_type_1; - type pthread_mutex_t is access record_type_1; - type pthread_mutexattr_t is access record_type_1; - type pthread_cond_t is access record_type_1; - type pthread_condattr_t is access record_type_1; + type pthread_t is new System.Address; + type pthread_attr_t is new System.Address; + type pthread_mutex_t is new System.Address; + type pthread_mutexattr_t is new System.Address; + type pthread_cond_t is new System.Address; + type pthread_condattr_t is new System.Address; type pthread_key_t is new int; end System.OS_Interface; diff --git a/lang/gnat/files/5fsystem.ads b/lang/gnat/files/system-freebsd-x86.ads index e7fb766e44bb..45216d111ec0 100644 --- a/lang/gnat/files/5fsystem.ads +++ b/lang/gnat/files/system-freebsd-x86.ads @@ -5,11 +5,9 @@ -- S Y S T E M -- -- -- -- S p e c -- --- (Default Version) -- +-- (FreeBSD/x86 Version) -- -- -- --- $Revision: 1.40 $ --- -- --- Copyright (C) 1992-2000 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -23,8 +21,8 @@ -- 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. -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, 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, -- @@ -34,14 +32,15 @@ -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- --- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ package System is -pragma Pure (System); --- Note that we take advantage of the implementation permission to --- make this unit Pure instead of Preelaborable, see RM 13.7(36) + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). type Name is (SYSTEM_NAME_GNAT); System_Name : constant Name := SYSTEM_NAME_GNAT; @@ -60,7 +59,7 @@ pragma Pure (System); Max_Mantissa : constant := 63; Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - Tick : constant := 1.0; + Tick : constant := 0.000_001; -- Storage-related Declarations @@ -120,20 +119,35 @@ private Backend_Divide_Checks : constant Boolean := False; Backend_Overflow_Checks : constant Boolean := False; Command_Line_Args : constant Boolean := True; + Compiler_System_Version : constant Boolean := False; + Configurable_Run_Time : constant Boolean := False; Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; Fractional_Fixed_Ops : constant Boolean := False; Frontend_Layout : constant Boolean := False; Functions_Return_By_DSP : constant Boolean := False; - Long_Shifts_Inlined : constant Boolean := True; - High_Integrity_Mode : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; OpenVMS : constant Boolean := False; + Preallocated_Stacks : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := False; Stack_Check_Probes : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; ZCX_By_Default : constant Boolean := False; GCC_ZCX_Support : constant Boolean := False; Front_End_ZCX_Support : constant Boolean := False; + + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := True; + end System; |