source: rtems/contrib/crossrpms/patches/gcc-ada-4.3.2-rtems4.10-20080910.diff @ d45dff4

4.104.11
Last change on this file since d45dff4 was d45dff4, checked in by Joel Sherrill <joel.sherrill@…>, on Sep 25, 2008 at 6:28:24 PM

2008-09-25 Joel Sherrill <joel.sherrill@…>

  • rtems4.10/sparc/Makefile.am: Bump RTEMS CPU Kit version.
  • patches/gcc-ada-4.3.2-rtems4.10-20080910.diff: New file.
  • patches/gcc-ada-4.2.0-rtems4.8-20070705.diff: Removed.
  • Property mode set to 100644
File size: 96.5 KB
  • gcc/ada/gsocket.h

    diff -urN gcc-4.3.2-orig/gcc/ada/gsocket.h gcc-4.3.2/gcc/ada/gsocket.h
    old new  
    175175
    176176#if defined (_AIX) || defined (__FreeBSD__) || defined (__hpux__) || defined (__osf__) || defined (_WIN32) || defined (__APPLE__)
    177177# define HAVE_THREAD_SAFE_GETxxxBYyyy 1
    178 #elif defined (sgi) || defined (linux) || (defined (sun) && defined (__SVR4) && !defined (__vxworks))
     178#elif defined (sgi) || defined (linux) || (defined (sun) && defined (__SVR4) && !defined (__vxworks)) || defined(__rtems__)
    179179# define HAVE_GETxxxBYyyy_R 1
    180180#endif
    181181
  • gcc/ada/Makefile.in

    diff -urN gcc-4.3.2-orig/gcc/ada/Makefile.in gcc-4.3.2/gcc/ada/Makefile.in
    old new  
    392392  a-intnam.ads<a-intnam-vxworks.ads \
    393393  a-numaux.ads<a-numaux-vxworks.ads \
    394394  s-inmaop.adb<s-inmaop-posix.adb \
    395   s-interr.adb<s-interr-vxworks.adb \
     395  s-interr.adb<s-interr-hwint.adb \
    396396  s-intman.ads<s-intman-vxworks.ads \
    397397  s-intman.adb<s-intman-vxworks.adb \
    398398  s-osinte.adb<s-osinte-vxworks.adb \
     
    473473    EXTRA_GNATRTL_NONTASKING_OBJS=s-vxwexc.o
    474474  else
    475475    LIBGNAT_TARGET_PAIRS += \
    476     s-interr.adb<s-interr-vxworks.adb \
     476    s-interr.adb<s-interr-hwint.adb \
    477477    s-tpopsp.adb<s-tpopsp-vxworks.adb \
    478478    system.ads<system-vxworks-ppc.ads
    479479
     
    506506  g-io.adb<g-io-vxworks-ppc-cert.adb \
    507507  g-io.ads<g-io-vxworks-ppc-cert.ads \
    508508  s-inmaop.adb<s-inmaop-posix.adb \
    509   s-interr.adb<s-interr-vxworks.adb \
     509  s-interr.adb<s-interr-hwint.adb \
    510510  s-intman.ads<s-intman-vxworks.ads \
    511511  s-intman.adb<s-intman-vxworks.adb \
    512512  s-osinte.adb<s-osinte-vxworks.adb \
     
    553553  a-intnam.ads<a-intnam-vxworks.ads \
    554554  a-numaux.ads<a-numaux-vxworks.ads \
    555555  s-inmaop.adb<s-inmaop-posix.adb \
    556   s-interr.adb<s-interr-vxworks.adb \
     556  s-interr.adb<s-interr-hwint.adb \
    557557  s-intman.ads<s-intman-vxworks.ads \
    558558  s-intman.adb<s-intman-vxworks.adb \
    559559  s-osinte.adb<s-osinte-vxworks.adb \
     
    628628    EXTRA_GNATRTL_NONTASKING_OBJS=s-vxwexc.o
    629629  else
    630630    LIBGNAT_TARGET_PAIRS += \
    631     s-interr.adb<s-interr-vxworks.adb \
     631    s-interr.adb<s-interr-hwint.adb \
    632632    s-tpopsp.adb<s-tpopsp-vxworks.adb \
    633633    system.ads<system-vxworks-x86.ads
    634634
     
    656656  a-intnam.ads<a-intnam-vxworks.ads \
    657657  a-numaux.ads<a-numaux-vxworks.ads \
    658658  s-inmaop.adb<s-inmaop-posix.adb \
    659   s-interr.adb<s-interr-vxworks.adb \
     659  s-interr.adb<s-interr-hwint.adb \
    660660  s-intman.ads<s-intman-vxworks.ads \
    661661  s-intman.adb<s-intman-vxworks.adb \
    662662  s-osinte.adb<s-osinte-vxworks.adb \
     
    11481148  s-taspri.ads<s-taspri-posix.ads \
    11491149  s-tpopsp.adb<s-tpopsp-rtems.adb \
    11501150  g-soccon.ads<g-soccon-rtems.ads \
    1151   s-stchop.adb<s-stchop-rtems.adb
     1151  s-stchop.adb<s-stchop-rtems.adb \
     1152  s-interr.adb<s-interr-hwint.adb
    11521153endif
    11531154
    11541155ifeq ($(strip $(filter-out alpha% dec osf%,$(targ))),)
  • gcc/ada/s-interr-hwint.adb

    diff -urN gcc-4.3.2-orig/gcc/ada/s-interr-hwint.adb gcc-4.3.2/gcc/ada/s-interr-hwint.adb
    old new  
     1------------------------------------------------------------------------------
     2--                                                                          --
     3--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
     4--                                                                          --
     5--                     S Y S T E M . I N T E R R U P T S                    --
     6--                                                                          --
     7--                                  B o d y                                 --
     8--                                                                          --
     9--         Copyright (C) 1992-2008, Free Software Foundation, Inc.          --
     10--                                                                          --
     11-- GNARL is free software; you can  redistribute it  and/or modify it under --
     12-- terms of the  GNU General Public License as published  by the Free Soft- --
     13-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
     14-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
     15-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
     16-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
     17-- for  more details.  You should have  received  a copy of the GNU General --
     18-- Public License  distributed with GNARL; see file COPYING.  If not, write --
     19-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
     20-- Boston, MA 02110-1301, USA.                                              --
     21--                                                                          --
     22-- As a special exception,  if other files  instantiate  generics from this --
     23-- unit, or you link  this unit with other files  to produce an executable, --
     24-- this  unit  does not  by itself cause  the resulting  executable  to  be --
     25-- covered  by the  GNU  General  Public  License.  This exception does not --
     26-- however invalidate  any other reasons why  the executable file  might be --
     27-- covered by the  GNU Public License.                                      --
     28--                                                                          --
     29-- GNARL was developed by the GNARL team at Florida State University.       --
     30-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
     31--                                                                          --
     32------------------------------------------------------------------------------
     33
     34--  Invariants:
     35
     36--  All user-handleable signals are masked at all times in all tasks/threads
     37--  except possibly for the Interrupt_Manager task.
     38
     39--  When a user task wants to have the effect of masking/unmasking an signal,
     40--  it must call Block_Interrupt/Unblock_Interrupt, which will have the effect
     41--  of unmasking/masking the signal in the Interrupt_Manager task. These
     42--  comments do not apply to vectored hardware interrupts, which may be masked
     43--  or unmasked using routined interfaced to the relevant embedded RTOS system
     44--  calls.
     45
     46--  Once we associate a Signal_Server_Task with an signal, the task never goes
     47--  away, and we never remove the association. On the other hand, it is more
     48--  convenient to terminate an associated Interrupt_Server_Task for a vectored
     49--  hardware interrupt (since we use a binary semaphore for synchronization
     50--  with the umbrella handler).
     51
     52--  There is no more than one signal per Signal_Server_Task and no more than
     53--  one Signal_Server_Task per signal. The same relation holds for hardware
     54--  interrupts and Interrupt_Server_Task's at any given time. That is, only
     55--  one non-terminated Interrupt_Server_Task exists for a give interrupt at
     56--  any time.
     57
     58--  Within this package, the lock L is used to protect the various status
     59--  tables. If there is a Server_Task associated with a signal or interrupt,
     60--  we use the per-task lock of the Server_Task instead so that we protect the
     61--  status between Interrupt_Manager and Server_Task. Protection among
     62--  service requests are ensured via user calls to the Interrupt_Manager
     63--  entries.
     64
     65--  This is reasonably generic version of this package, supporting vectored
     66--  hardware interrupts using non-RTOS specific adapter routines which
     67--  should easily implemented on any RTOS capable of supporting GNAT.
     68
     69with Unchecked_Conversion;
     70
     71with System.OS_Interface; use System.OS_Interface;
     72
     73with Ada.Task_Identification;
     74--  used for Task_Id type
     75
     76with Ada.Exceptions;
     77--  used for Raise_Exception
     78
     79with System.Interrupt_Management;
     80--  used for Reserve
     81
     82with System.Task_Primitives.Operations;
     83--  used for Write_Lock
     84--           Unlock
     85--           Abort
     86--           Wakeup_Task
     87--           Sleep
     88--           Initialize_Lock
     89
     90with System.Storage_Elements;
     91--  used for To_Address
     92--           To_Integer
     93--           Integer_Address
     94
     95with System.Tasking.Utilities;
     96--  used for Make_Independent
     97
     98with System.Tasking.Rendezvous;
     99--  used for Call_Simple
     100pragma Elaborate_All (System.Tasking.Rendezvous);
     101
     102package body System.Interrupts is
     103
     104   use Tasking;
     105   use Ada.Exceptions;
     106
     107   package POP renames System.Task_Primitives.Operations;
     108
     109   function To_Ada is new Unchecked_Conversion
     110     (System.Tasking.Task_Id, Ada.Task_Identification.Task_Id);
     111
     112   function To_System is new Unchecked_Conversion
     113     (Ada.Task_Identification.Task_Id, Task_Id);
     114
     115   -----------------
     116   -- Local Tasks --
     117   -----------------
     118
     119   --  WARNING: System.Tasking.Stages performs calls to this task with
     120   --  low-level constructs. Do not change this spec without synchronizing it.
     121
     122   task Interrupt_Manager is
     123      entry Detach_Interrupt_Entries (T : Task_Id);
     124
     125      entry Attach_Handler
     126        (New_Handler : Parameterless_Handler;
     127         Interrupt   : Interrupt_ID;
     128         Static      : Boolean;
     129         Restoration : Boolean := False);
     130
     131      entry Exchange_Handler
     132        (Old_Handler : out Parameterless_Handler;
     133         New_Handler : Parameterless_Handler;
     134         Interrupt   : Interrupt_ID;
     135         Static      : Boolean);
     136
     137      entry Detach_Handler
     138        (Interrupt : Interrupt_ID;
     139         Static    : Boolean);
     140
     141      entry Bind_Interrupt_To_Entry
     142        (T         : Task_Id;
     143         E         : Task_Entry_Index;
     144         Interrupt : Interrupt_ID);
     145
     146      pragma Interrupt_Priority (System.Interrupt_Priority'First);
     147   end Interrupt_Manager;
     148
     149   task type Interrupt_Server_Task
     150     (Interrupt : Interrupt_ID; Int_Sema : Binary_Semaphore_Id) is
     151      --  Server task for vectored hardware interrupt handling
     152      pragma Interrupt_Priority (System.Interrupt_Priority'First + 2);
     153   end Interrupt_Server_Task;
     154
     155   type Interrupt_Task_Access is access Interrupt_Server_Task;
     156
     157   -------------------------------
     158   -- Local Types and Variables --
     159   -------------------------------
     160
     161   type Entry_Assoc is record
     162      T : Task_Id;
     163      E : Task_Entry_Index;
     164   end record;
     165
     166   type Handler_Assoc is record
     167      H      : Parameterless_Handler;
     168      Static : Boolean;   --  Indicates static binding;
     169   end record;
     170
     171   User_Handler : array (Interrupt_ID) of Handler_Assoc :=
     172     (others => (null, Static => False));
     173   pragma Volatile_Components (User_Handler);
     174   --  Holds the protected procedure handler (if any) and its Static
     175   --  information  for each interrupt or signal. A handler is static
     176   --  iff it is specified through the pragma Attach_Handler.
     177
     178   User_Entry : array (Interrupt_ID) of Entry_Assoc :=
     179     (others => (T => Null_Task, E => Null_Task_Entry));
     180   pragma Volatile_Components (User_Entry);
     181   --  Holds the task and entry index (if any) for each interrupt / signal
     182
     183   --  Type and Head, Tail of the list containing Registered Interrupt
     184   --  Handlers. These definitions are used to register the handlers
     185   --  specified by the pragma Interrupt_Handler.
     186
     187   type Registered_Handler;
     188   type R_Link is access all Registered_Handler;
     189
     190   type Registered_Handler is record
     191      H    : System.Address := System.Null_Address;
     192      Next : R_Link := null;
     193   end record;
     194
     195   Registered_Handler_Head : R_Link := null;
     196   Registered_Handler_Tail : R_Link := null;
     197
     198   Server_ID : array (Interrupt_ID) of System.Tasking.Task_Id :=
     199     (others => System.Tasking.Null_Task);
     200   pragma Atomic_Components (Server_ID);
     201   --  Holds the Task_Id of the Server_Task for each interrupt / signal.
     202   --  Task_Id is needed to accomplish locking per interrupt base. Also
     203   --  is needed to determine whether to create a new Server_Task.
     204
     205   Semaphore_ID_Map : array
     206     (Interrupt_ID range 0 .. System.OS_Interface.Max_HW_Interrupt)
     207      of Binary_Semaphore_Id := (others => 0);
     208   --  Array of binary semaphores associated with vectored interrupts
     209   --  Note that the last bound should be Max_HW_Interrupt, but this will raise
     210   --  Storage_Error if Num_HW_Interrupts is null, so use an extra 4 bytes
     211   --  instead.
     212
     213   Interrupt_Access_Hold : Interrupt_Task_Access;
     214   --  Variable for allocating an Interrupt_Server_Task
     215
     216   Default_Handler : array (HW_Interrupt) of
     217      System.OS_Interface.Interrupt_Handler;
     218   --  Vectored interrupt handlers installed prior to program startup.
     219   --  These are saved only when the umbrella handler is installed for
     220   --  a given interrupt number.
     221
     222   -----------------------
     223   -- Local Subprograms --
     224   -----------------------
     225
     226   procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID);
     227   --  Check if Id is a reserved interrupt, and if so raise Program_Error
     228   --  with an appropriate message, otherwise return.
     229
     230   procedure Finalize_Interrupt_Servers;
     231   --  Unbind the handlers for hardware interrupt server tasks at program
     232   --  termination.
     233
     234   function Is_Registered (Handler : Parameterless_Handler) return Boolean;
     235   --  See if Handler has been "pragma"ed using Interrupt_Handler.
     236   --  Always consider a null handler as registered.
     237
     238   procedure Notify_Interrupt (Param : System.Address);
     239   pragma Convention (C, Notify_Interrupt);
     240   --  Umbrella handler for vectored interrupts (not signals)
     241
     242   procedure Install_Default_Action (Interrupt : HW_Interrupt);
     243   --  Restore a handler that was in place prior to program execution
     244
     245   procedure Install_Umbrella_Handler
     246     (Interrupt : HW_Interrupt;
     247      Handler   : System.OS_Interface.Interrupt_Handler);
     248   --  Install the runtime umbrella handler for a vectored hardware
     249   --  interrupt
     250
     251   procedure Unimplemented (Feature : String);
     252   pragma No_Return (Unimplemented);
     253   --  Used to mark a call to an unimplemented function. Raises Program_Error
     254   --  with an appropriate message noting that Feature is unimplemented.
     255
     256   --------------------
     257   -- Attach_Handler --
     258   --------------------
     259
     260   --  Calling this procedure with New_Handler = null and Static = True
     261   --  means we want to detach the current handler regardless of the
     262   --  previous handler's binding status (ie. do not care if it is a
     263   --  dynamic or static handler).
     264
     265   --  This option is needed so that during the finalization of a PO, we
     266   --  can detach handlers attached through pragma Attach_Handler.
     267
     268   procedure Attach_Handler
     269     (New_Handler : Parameterless_Handler;
     270      Interrupt   : Interrupt_ID;
     271      Static      : Boolean := False) is
     272   begin
     273      Check_Reserved_Interrupt (Interrupt);
     274      Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static);
     275   end Attach_Handler;
     276
     277   -----------------------------
     278   -- Bind_Interrupt_To_Entry --
     279   -----------------------------
     280
     281   --  This procedure raises a Program_Error if it tries to
     282   --  bind an interrupt to which an Entry or a Procedure is
     283   --  already bound.
     284
     285   procedure Bind_Interrupt_To_Entry
     286     (T       : Task_Id;
     287      E       : Task_Entry_Index;
     288      Int_Ref : System.Address)
     289   is
     290      Interrupt : constant Interrupt_ID :=
     291        Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
     292
     293   begin
     294      Check_Reserved_Interrupt (Interrupt);
     295      Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
     296   end Bind_Interrupt_To_Entry;
     297
     298   ---------------------
     299   -- Block_Interrupt --
     300   ---------------------
     301
     302   procedure Block_Interrupt (Interrupt : Interrupt_ID) is
     303   begin
     304      Unimplemented ("Block_Interrupt");
     305   end Block_Interrupt;
     306
     307   ------------------------------
     308   -- Check_Reserved_Interrupt --
     309   ------------------------------
     310
     311   procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID) is
     312   begin
     313      if Is_Reserved (Interrupt) then
     314         Raise_Exception
     315           (Program_Error'Identity,
     316            "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved");
     317      else
     318         return;
     319      end if;
     320   end Check_Reserved_Interrupt;
     321
     322   ---------------------
     323   -- Current_Handler --
     324   ---------------------
     325
     326   function Current_Handler
     327     (Interrupt : Interrupt_ID) return Parameterless_Handler
     328   is
     329   begin
     330      Check_Reserved_Interrupt (Interrupt);
     331
     332      --  ??? Since Parameterless_Handler is not Atomic, the
     333      --  current implementation is wrong. We need a new service in
     334      --  Interrupt_Manager to ensure atomicity.
     335
     336      return User_Handler (Interrupt).H;
     337   end Current_Handler;
     338
     339   --------------------
     340   -- Detach_Handler --
     341   --------------------
     342
     343   --  Calling this procedure with Static = True means we want to Detach the
     344   --  current handler regardless of the previous handler's binding status
     345   --  (i.e. do not care if it is a dynamic or static handler).
     346
     347   --  This option is needed so that during the finalization of a PO, we can
     348   --  detach handlers attached through pragma Attach_Handler.
     349
     350   procedure Detach_Handler
     351     (Interrupt : Interrupt_ID;
     352      Static    : Boolean := False) is
     353   begin
     354      Check_Reserved_Interrupt (Interrupt);
     355      Interrupt_Manager.Detach_Handler (Interrupt, Static);
     356   end Detach_Handler;
     357
     358   ------------------------------
     359   -- Detach_Interrupt_Entries --
     360   ------------------------------
     361
     362   procedure Detach_Interrupt_Entries (T : Task_Id) is
     363   begin
     364      Interrupt_Manager.Detach_Interrupt_Entries (T);
     365   end Detach_Interrupt_Entries;
     366
     367   ----------------------
     368   -- Exchange_Handler --
     369   ----------------------
     370
     371   --  Calling this procedure with New_Handler = null and Static = True
     372   --  means we want to detach the current handler regardless of the
     373   --  previous handler's binding status (ie. do not care if it is a
     374   --  dynamic or static handler).
     375
     376   --  This option is needed so that during the finalization of a PO, we
     377   --  can detach handlers attached through pragma Attach_Handler.
     378
     379   procedure Exchange_Handler
     380     (Old_Handler : out Parameterless_Handler;
     381      New_Handler : Parameterless_Handler;
     382      Interrupt   : Interrupt_ID;
     383      Static      : Boolean := False)
     384   is
     385   begin
     386      Check_Reserved_Interrupt (Interrupt);
     387      Interrupt_Manager.Exchange_Handler
     388        (Old_Handler, New_Handler, Interrupt, Static);
     389   end Exchange_Handler;
     390
     391   --------------
     392   -- Finalize --
     393   --------------
     394
     395   procedure Finalize (Object : in out Static_Interrupt_Protection) is
     396   begin
     397      --  ??? loop to be executed only when we're not doing library level
     398      --  finalization, since in this case all interrupt / signal tasks are
     399      --  gone.
     400
     401      if not Interrupt_Manager'Terminated then
     402         for N in reverse Object.Previous_Handlers'Range loop
     403            Interrupt_Manager.Attach_Handler
     404              (New_Handler => Object.Previous_Handlers (N).Handler,
     405               Interrupt   => Object.Previous_Handlers (N).Interrupt,
     406               Static      => Object.Previous_Handlers (N).Static,
     407               Restoration => True);
     408         end loop;
     409      end if;
     410
     411      Tasking.Protected_Objects.Entries.Finalize
     412        (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
     413   end Finalize;
     414
     415   --------------------------------
     416   -- Finalize_Interrupt_Servers --
     417   --------------------------------
     418
     419   --  Restore default handlers for interrupt servers
     420
     421   --  This is called by the Interrupt_Manager task when it receives the abort
     422   --  signal during program finalization.
     423
     424   procedure Finalize_Interrupt_Servers is
     425      HW_Interrupts : constant Boolean := HW_Interrupt'Last >= 0;
     426
     427   begin
     428      if HW_Interrupts then
     429         for Int in HW_Interrupt loop
     430            if Server_ID (Interrupt_ID (Int)) /= null
     431              and then
     432                not Ada.Task_Identification.Is_Terminated
     433                 (To_Ada (Server_ID (Interrupt_ID (Int))))
     434            then
     435               Interrupt_Manager.Attach_Handler
     436                 (New_Handler => null,
     437                  Interrupt => Interrupt_ID (Int),
     438                  Static => True,
     439                  Restoration => True);
     440            end if;
     441         end loop;
     442      end if;
     443   end Finalize_Interrupt_Servers;
     444
     445   -------------------------------------
     446   -- Has_Interrupt_Or_Attach_Handler --
     447   -------------------------------------
     448
     449   function Has_Interrupt_Or_Attach_Handler
     450     (Object : access Dynamic_Interrupt_Protection)
     451      return   Boolean
     452   is
     453      pragma Unreferenced (Object);
     454   begin
     455      return True;
     456   end Has_Interrupt_Or_Attach_Handler;
     457
     458   function Has_Interrupt_Or_Attach_Handler
     459     (Object : access Static_Interrupt_Protection)
     460      return   Boolean
     461   is
     462      pragma Unreferenced (Object);
     463   begin
     464      return True;
     465   end Has_Interrupt_Or_Attach_Handler;
     466
     467   ----------------------
     468   -- Ignore_Interrupt --
     469   ----------------------
     470
     471   procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
     472   begin
     473      Unimplemented ("Ignore_Interrupt");
     474   end Ignore_Interrupt;
     475
     476   ----------------------------
     477   -- Install_Default_Action --
     478   ----------------------------
     479
     480   procedure Install_Default_Action (Interrupt : HW_Interrupt) is
     481   begin
     482      --  Restore original interrupt handler
     483
     484      Interrupt_Vector_Set
     485        (System.OS_Interface.Interrupt_Number_To_Vector (int (Interrupt)),
     486         Default_Handler (Interrupt));
     487      Default_Handler (Interrupt) := null;
     488   end Install_Default_Action;
     489
     490   ----------------------
     491   -- Install_Handlers --
     492   ----------------------
     493
     494   procedure Install_Handlers
     495     (Object       : access Static_Interrupt_Protection;
     496      New_Handlers : New_Handler_Array)
     497   is
     498   begin
     499      for N in New_Handlers'Range loop
     500
     501         --  We need a lock around this ???
     502
     503         Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
     504         Object.Previous_Handlers (N).Static    := User_Handler
     505           (New_Handlers (N).Interrupt).Static;
     506
     507         --  We call Exchange_Handler and not directly Interrupt_Manager.
     508         --  Exchange_Handler so we get the Is_Reserved check.
     509
     510         Exchange_Handler
     511           (Old_Handler => Object.Previous_Handlers (N).Handler,
     512            New_Handler => New_Handlers (N).Handler,
     513            Interrupt   => New_Handlers (N).Interrupt,
     514            Static      => True);
     515      end loop;
     516   end Install_Handlers;
     517
     518   ------------------------------
     519   -- Install_Umbrella_Handler --
     520   ------------------------------
     521
     522   procedure Install_Umbrella_Handler
     523     (Interrupt : HW_Interrupt;
     524      Handler   : System.OS_Interface.Interrupt_Handler)
     525   is
     526      Vec : constant Interrupt_Vector :=
     527              Interrupt_Number_To_Vector (int (Interrupt));
     528
     529      Old_Handler : constant System.OS_Interface.Interrupt_Handler :=
     530         Interrupt_Vector_Get (Interrupt_Number_To_Vector (int (Interrupt)));
     531
     532      Status : int;
     533      pragma Unreferenced (Status);
     534      --  ??? shouldn't we test Stat at least in a pragma Assert?
     535   begin
     536      --  Only install umbrella handler when no Ada handler has already been
     537      --  installed. Note that the interrupt number is passed as a parameter
     538      --  when an interrupt occurs, so the umbrella handler has a different
     539      --  wrapper generated by intConnect for each interrupt number.
     540
     541      if Default_Handler (Interrupt) = null then
     542         Status := Interrupt_Connect
     543            (Vec, Handler, System.Address (Interrupt));
     544         Default_Handler (Interrupt) := Old_Handler;
     545      end if;
     546   end Install_Umbrella_Handler;
     547
     548   ----------------
     549   -- Is_Blocked --
     550   ----------------
     551
     552   function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
     553   begin
     554      Unimplemented ("Is_Blocked");
     555      return False;
     556   end Is_Blocked;
     557
     558   -----------------------
     559   -- Is_Entry_Attached --
     560   -----------------------
     561
     562   function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
     563   begin
     564      Check_Reserved_Interrupt (Interrupt);
     565      return User_Entry (Interrupt).T /= Null_Task;
     566   end Is_Entry_Attached;
     567
     568   -------------------------
     569   -- Is_Handler_Attached --
     570   -------------------------
     571
     572   function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
     573   begin
     574      Check_Reserved_Interrupt (Interrupt);
     575      return User_Handler (Interrupt).H /= null;
     576   end Is_Handler_Attached;
     577
     578   ----------------
     579   -- Is_Ignored --
     580   ----------------
     581
     582   function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
     583   begin
     584      Unimplemented ("Is_Ignored");
     585      return False;
     586   end Is_Ignored;
     587
     588   -------------------
     589   -- Is_Registered --
     590   -------------------
     591
     592   function Is_Registered (Handler : Parameterless_Handler) return Boolean is
     593      type Fat_Ptr is record
     594         Object_Addr  : System.Address;
     595         Handler_Addr : System.Address;
     596      end record;
     597
     598      function To_Fat_Ptr is new Unchecked_Conversion
     599        (Parameterless_Handler, Fat_Ptr);
     600
     601      Ptr : R_Link;
     602      Fat : Fat_Ptr;
     603
     604   begin
     605      if Handler = null then
     606         return True;
     607      end if;
     608
     609      Fat := To_Fat_Ptr (Handler);
     610
     611      Ptr := Registered_Handler_Head;
     612
     613      while Ptr /= null loop
     614         if Ptr.H = Fat.Handler_Addr then
     615            return True;
     616         end if;
     617
     618         Ptr := Ptr.Next;
     619      end loop;
     620
     621      return False;
     622   end Is_Registered;
     623
     624   -----------------
     625   -- Is_Reserved --
     626   -----------------
     627
     628   function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
     629      use System.Interrupt_Management;
     630   begin
     631      return Reserve (System.Interrupt_Management.Interrupt_ID (Interrupt));
     632   end Is_Reserved;
     633
     634   ----------------------
     635   -- Notify_Interrupt --
     636   ----------------------
     637
     638   --  Umbrella handler for vectored hardware interrupts (as opposed to
     639   --  signals and exceptions).  As opposed to the signal implementation,
     640   --  this handler is only installed in the vector table while there is
     641   --  an active association of an Ada handler to the interrupt.
     642
     643   --  Otherwise, the handler that existed prior to program startup is
     644   --  in the vector table.  This ensures that handlers installed by
     645   --  the BSP are active unless explicitly replaced in the program text.
     646
     647   --  Each Interrupt_Server_Task has an associated binary semaphore
     648   --  on which it pends once it's been started.  This routine determines
     649   --  The appropriate semaphore and and issues a Binary_Semaphore_Release
     650   --  call, waking the server task.  When a handler is unbound,
     651   --  System.Interrupts.Unbind_Handler issues a Binary_Semaphore_Flush,
     652   --  and the server task deletes its semaphore and terminates.
     653
     654   procedure Notify_Interrupt (Param : System.Address) is
     655      Interrupt : constant Interrupt_ID := Interrupt_ID (Param);
     656
     657      Status : int;
     658      pragma Unreferenced (Status);
     659      --  ??? shouldn't we test Stat at least in a pragma Assert?
     660   begin
     661      Status := Binary_Semaphore_Release (Semaphore_ID_Map (Interrupt));
     662   end Notify_Interrupt;
     663
     664   ---------------
     665   -- Reference --
     666   ---------------
     667
     668   function Reference (Interrupt : Interrupt_ID) return System.Address is
     669   begin
     670      Check_Reserved_Interrupt (Interrupt);
     671      return Storage_Elements.To_Address
     672        (Storage_Elements.Integer_Address (Interrupt));
     673   end Reference;
     674
     675   --------------------------------
     676   -- Register_Interrupt_Handler --
     677   --------------------------------
     678
     679   procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
     680      New_Node_Ptr : R_Link;
     681
     682   begin
     683      --  This routine registers a handler as usable for dynamic
     684      --  interrupt handler association. Routines attaching and detaching
     685      --  handlers dynamically should determine whether the handler is
     686      --  registered. Program_Error should be raised if it is not registered.
     687
     688      --  Pragma Interrupt_Handler can only appear in a library
     689      --  level PO definition and instantiation. Therefore, we do not need
     690      --  to implement an unregister operation. Nor do we need to
     691      --  protect the queue structure with a lock.
     692
     693      pragma Assert (Handler_Addr /= System.Null_Address);
     694
     695      New_Node_Ptr := new Registered_Handler;
     696      New_Node_Ptr.H := Handler_Addr;
     697
     698      if Registered_Handler_Head = null then
     699         Registered_Handler_Head := New_Node_Ptr;
     700         Registered_Handler_Tail := New_Node_Ptr;
     701
     702      else
     703         Registered_Handler_Tail.Next := New_Node_Ptr;
     704         Registered_Handler_Tail := New_Node_Ptr;
     705      end if;
     706   end Register_Interrupt_Handler;
     707
     708   -----------------------
     709   -- Unblock_Interrupt --
     710   -----------------------
     711
     712   procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
     713   begin
     714      Unimplemented ("Unblock_Interrupt");
     715   end Unblock_Interrupt;
     716
     717   ------------------
     718   -- Unblocked_By --
     719   ------------------
     720
     721   function Unblocked_By
     722     (Interrupt : Interrupt_ID) return System.Tasking.Task_Id
     723   is
     724   begin
     725      Unimplemented ("Unblocked_By");
     726      return Null_Task;
     727   end Unblocked_By;
     728
     729   ------------------------
     730   -- Unignore_Interrupt --
     731   ------------------------
     732
     733   procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
     734   begin
     735      Unimplemented ("Unignore_Interrupt");
     736   end Unignore_Interrupt;
     737
     738   -------------------
     739   -- Unimplemented --
     740   -------------------
     741
     742   procedure Unimplemented (Feature : String) is
     743   begin
     744      Raise_Exception
     745        (Program_Error'Identity,
     746         Feature & " not implemented for hardware interrupts");
     747   end Unimplemented;
     748
     749   -----------------------
     750   -- Interrupt_Manager --
     751   -----------------------
     752
     753   task body Interrupt_Manager is
     754
     755      --------------------
     756      -- Local Routines --
     757      --------------------
     758
     759      procedure Bind_Handler (Interrupt : Interrupt_ID);
     760      --  This procedure does not do anything if a signal is blocked.
     761      --  Otherwise, we have to interrupt Server_Task for status change through
     762      --  a wakeup signal.
     763
     764      procedure Unbind_Handler (Interrupt : Interrupt_ID);
     765      --  This procedure does not do anything if a signal is blocked.
     766      --  Otherwise, we have to interrupt Server_Task for status change
     767      --  through an abort signal.
     768
     769      procedure Unprotected_Exchange_Handler
     770        (Old_Handler : out Parameterless_Handler;
     771         New_Handler : Parameterless_Handler;
     772         Interrupt   : Interrupt_ID;
     773         Static      : Boolean;
     774         Restoration : Boolean := False);
     775
     776      procedure Unprotected_Detach_Handler
     777        (Interrupt : Interrupt_ID;
     778         Static    : Boolean);
     779
     780      ------------------
     781      -- Bind_Handler --
     782      ------------------
     783
     784      procedure Bind_Handler (Interrupt : Interrupt_ID) is
     785      begin
     786         Install_Umbrella_Handler
     787           (HW_Interrupt (Interrupt), Notify_Interrupt'Access);
     788      end Bind_Handler;
     789
     790      --------------------
     791      -- Unbind_Handler --
     792      --------------------
     793
     794      procedure Unbind_Handler (Interrupt : Interrupt_ID) is
     795         Status : int;
     796         pragma Unreferenced (Status);
     797         --  ??? shouldn't we test Stat at least in a pragma Assert?
     798      begin
     799         --  Hardware interrupt
     800
     801         Install_Default_Action (HW_Interrupt (Interrupt));
     802
     803         --  Flush server task off semaphore, allowing it to terminate
     804
     805         Status := Binary_Semaphore_Flush (Semaphore_ID_Map (Interrupt));
     806      end Unbind_Handler;
     807
     808      --------------------------------
     809      -- Unprotected_Detach_Handler --
     810      --------------------------------
     811
     812      procedure Unprotected_Detach_Handler
     813        (Interrupt : Interrupt_ID;
     814         Static    : Boolean)
     815      is
     816         Old_Handler : Parameterless_Handler;
     817      begin
     818         if User_Entry (Interrupt).T /= Null_Task then
     819            --  If an interrupt entry is installed raise
     820            --  Program_Error. (propagate it to the caller).
     821
     822            Raise_Exception (Program_Error'Identity,
     823              "An interrupt entry is already installed");
     824         end if;
     825
     826         --  Note : Static = True will pass the following check. This is the
     827         --  case when we want to detach a handler regardless of the static
     828         --  status of the Current_Handler.
     829
     830         if not Static and then User_Handler (Interrupt).Static then
     831
     832            --  Trying to detach a static Interrupt Handler. raise
     833            --  Program_Error.
     834
     835            Raise_Exception (Program_Error'Identity,
     836              "Trying to detach a static Interrupt Handler");
     837         end if;
     838
     839         Old_Handler := User_Handler (Interrupt).H;
     840
     841         --  The new handler
     842
     843         User_Handler (Interrupt).H := null;
     844         User_Handler (Interrupt).Static := False;
     845
     846         if Old_Handler /= null then
     847            Unbind_Handler (Interrupt);
     848         end if;
     849      end Unprotected_Detach_Handler;
     850
     851      ----------------------------------
     852      -- Unprotected_Exchange_Handler --
     853      ----------------------------------
     854
     855      procedure Unprotected_Exchange_Handler
     856        (Old_Handler : out Parameterless_Handler;
     857         New_Handler : Parameterless_Handler;
     858         Interrupt   : Interrupt_ID;
     859         Static      : Boolean;
     860         Restoration : Boolean := False)
     861      is
     862      begin
     863         if User_Entry (Interrupt).T /= Null_Task then
     864
     865            --  If an interrupt entry is already installed, raise
     866            --  Program_Error. (propagate it to the caller).
     867
     868            Raise_Exception
     869              (Program_Error'Identity,
     870               "An interrupt is already installed");
     871         end if;
     872
     873         --  Note : A null handler with Static = True will
     874         --  pass the following check. This is the case when we want to
     875         --  detach a handler regardless of the Static status
     876         --  of Current_Handler.
     877         --  We don't check anything if Restoration is True, since we
     878         --  may be detaching a static handler to restore a dynamic one.
     879
     880         if not Restoration and then not Static
     881           and then (User_Handler (Interrupt).Static
     882
     883            --  Trying to overwrite a static Interrupt Handler with a
     884            --  dynamic Handler
     885
     886            --  The new handler is not specified as an
     887            --  Interrupt Handler by a pragma.
     888
     889           or else not Is_Registered (New_Handler))
     890         then
     891            Raise_Exception
     892              (Program_Error'Identity,
     893               "Trying to overwrite a static Interrupt Handler with a " &
     894               "dynamic Handler");
     895         end if;
     896
     897         --  Save the old handler
     898
     899         Old_Handler := User_Handler (Interrupt).H;
     900
     901         --  The new handler
     902
     903         User_Handler (Interrupt).H := New_Handler;
     904
     905         if New_Handler = null then
     906
     907            --  The null handler means we are detaching the handler
     908
     909            User_Handler (Interrupt).Static := False;
     910
     911         else
     912            User_Handler (Interrupt).Static := Static;
     913         end if;
     914
     915         --  Invoke a corresponding Server_Task if not yet created.
     916         --  Place Task_Id info in Server_ID array.
     917
     918         if New_Handler /= null
     919           and then
     920            (Server_ID (Interrupt) = Null_Task
     921              or else
     922                Ada.Task_Identification.Is_Terminated
     923                  (To_Ada (Server_ID (Interrupt))))
     924         then
     925            Interrupt_Access_Hold :=
     926              new Interrupt_Server_Task (Interrupt, Binary_Semaphore_Create);
     927            Server_ID (Interrupt) :=
     928              To_System (Interrupt_Access_Hold.all'Identity);
     929         end if;
     930
     931         if (New_Handler = null) and then Old_Handler /= null then
     932
     933            --  Restore default handler
     934
     935            Unbind_Handler (Interrupt);
     936
     937         elsif Old_Handler = null then
     938
     939            --  Save default handler
     940
     941            Bind_Handler (Interrupt);
     942         end if;
     943      end Unprotected_Exchange_Handler;
     944
     945      --  Start of processing for Interrupt_Manager
     946
     947   begin
     948      --  By making this task independent of any master, when the process
     949      --  goes away, the Interrupt_Manager will terminate gracefully.
     950
     951      System.Tasking.Utilities.Make_Independent;
     952
     953      loop
     954         --  A block is needed to absorb Program_Error exception
     955
     956         declare
     957            Old_Handler : Parameterless_Handler;
     958
     959         begin
     960            select
     961               accept Attach_Handler
     962                 (New_Handler : Parameterless_Handler;
     963                  Interrupt   : Interrupt_ID;
     964                  Static      : Boolean;
     965                  Restoration : Boolean := False)
     966               do
     967                  Unprotected_Exchange_Handler
     968                    (Old_Handler, New_Handler, Interrupt, Static, Restoration);
     969               end Attach_Handler;
     970
     971            or
     972               accept Exchange_Handler
     973                 (Old_Handler : out Parameterless_Handler;
     974                  New_Handler : Parameterless_Handler;
     975                  Interrupt   : Interrupt_ID;
     976                  Static      : Boolean)
     977               do
     978                  Unprotected_Exchange_Handler
     979                    (Old_Handler, New_Handler, Interrupt, Static);
     980               end Exchange_Handler;
     981
     982            or
     983               accept Detach_Handler
     984                  (Interrupt   : Interrupt_ID;
     985                   Static      : Boolean)
     986               do
     987                  Unprotected_Detach_Handler (Interrupt, Static);
     988               end Detach_Handler;
     989            or
     990               accept Bind_Interrupt_To_Entry
     991                 (T       : Task_Id;
     992                  E       : Task_Entry_Index;
     993                  Interrupt : Interrupt_ID)
     994               do
     995                  --  If there is a binding already (either a procedure or an
     996                  --  entry), raise Program_Error (propagate it to the caller).
     997
     998                  if User_Handler (Interrupt).H /= null
     999                    or else User_Entry (Interrupt).T /= Null_Task
     1000                  then
     1001                     Raise_Exception
     1002                       (Program_Error'Identity,
     1003                        "A binding for this interrupt is already present");
     1004                  end if;
     1005
     1006                  User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E);
     1007
     1008                  --  Indicate the attachment of interrupt entry in the ATCB.
     1009                  --  This is needed so when an interrupt entry task terminates
     1010                  --  the binding can be cleaned. The call to unbinding must be
     1011                  --  make by the task before it terminates.
     1012
     1013                  T.Interrupt_Entry := True;
     1014
     1015                  --  Invoke a corresponding Server_Task if not yet created.
     1016                  --  Place Task_Id info in Server_ID array.
     1017
     1018                  if Server_ID (Interrupt) = Null_Task
     1019                    or else
     1020                      Ada.Task_Identification.Is_Terminated
     1021                        (To_Ada (Server_ID (Interrupt)))
     1022                  then
     1023                     Interrupt_Access_Hold := new Interrupt_Server_Task
     1024                       (Interrupt, Binary_Semaphore_Create);
     1025                     Server_ID (Interrupt) :=
     1026                       To_System (Interrupt_Access_Hold.all'Identity);
     1027                  end if;
     1028
     1029                  Bind_Handler (Interrupt);
     1030               end Bind_Interrupt_To_Entry;
     1031
     1032            or
     1033               accept Detach_Interrupt_Entries (T : Task_Id) do
     1034                  for Int in Interrupt_ID'Range loop
     1035                     if not Is_Reserved (Int) then
     1036                        if User_Entry (Int).T = T then
     1037                           User_Entry (Int) :=
     1038                             Entry_Assoc'
     1039                               (T => Null_Task, E => Null_Task_Entry);
     1040                           Unbind_Handler (Int);
     1041                        end if;
     1042                     end if;
     1043                  end loop;
     1044
     1045                  --  Indicate in ATCB that no interrupt entries are attached
     1046
     1047                  T.Interrupt_Entry := False;
     1048               end Detach_Interrupt_Entries;
     1049            end select;
     1050
     1051         exception
     1052            --  If there is a Program_Error we just want to propagate it to
     1053            --  the caller and do not want to stop this task.
     1054
     1055            when Program_Error =>
     1056               null;
     1057
     1058            when others =>
     1059               pragma Assert (False);
     1060               null;
     1061         end;
     1062      end loop;
     1063
     1064   exception
     1065      when Standard'Abort_Signal =>
     1066         --  Flush interrupt server semaphores, so they can terminate
     1067         Finalize_Interrupt_Servers;
     1068         raise;
     1069   end Interrupt_Manager;
     1070
     1071   ---------------------------
     1072   -- Interrupt_Server_Task --
     1073   ---------------------------
     1074
     1075   --  Server task for vectored hardware interrupt handling
     1076
     1077   task body Interrupt_Server_Task is
     1078      Self_Id         : constant Task_Id := Self;
     1079      Tmp_Handler     : Parameterless_Handler;
     1080      Tmp_ID          : Task_Id;
     1081      Tmp_Entry_Index : Task_Entry_Index;
     1082
     1083      Status : int;
     1084      pragma Unreferenced (Status);
     1085      --  ??? shouldn't we test Stat at least in a pragma Assert?
     1086   begin
     1087      System.Tasking.Utilities.Make_Independent;
     1088      Semaphore_ID_Map (Interrupt) := Int_Sema;
     1089
     1090      loop
     1091         --  Pend on semaphore that will be triggered by the
     1092         --  umbrella handler when the associated interrupt comes in
     1093
     1094         Status := Binary_Semaphore_Obtain (Int_Sema);
     1095
     1096         if User_Handler (Interrupt).H /= null then
     1097
     1098            --  Protected procedure handler
     1099
     1100            Tmp_Handler := User_Handler (Interrupt).H;
     1101            Tmp_Handler.all;
     1102
     1103         elsif User_Entry (Interrupt).T /= Null_Task then
     1104
     1105            --  Interrupt entry handler
     1106
     1107            Tmp_ID := User_Entry (Interrupt).T;
     1108            Tmp_Entry_Index := User_Entry (Interrupt).E;
     1109            System.Tasking.Rendezvous.Call_Simple
     1110              (Tmp_ID, Tmp_Entry_Index, System.Null_Address);
     1111
     1112         else
     1113            --  Semaphore has been flushed by an unbind operation in
     1114            --  the Interrupt_Manager. Terminate the server task.
     1115
     1116            --  Wait for the Interrupt_Manager to complete its work
     1117
     1118            POP.Write_Lock (Self_Id);
     1119
     1120            --  Delete the associated semaphore
     1121
     1122            Status := Binary_Semaphore_Delete (Int_Sema);
     1123
     1124            --  Set status for the Interrupt_Manager
     1125
     1126            Semaphore_ID_Map (Interrupt) := 0;
     1127            Server_ID (Interrupt) := Null_Task;
     1128            POP.Unlock (Self_Id);
     1129
     1130            exit;
     1131         end if;
     1132      end loop;
     1133   end Interrupt_Server_Task;
     1134
     1135begin
     1136   --  Get Interrupt_Manager's ID so that Abort_Interrupt can be sent
     1137
     1138   Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
     1139end System.Interrupts;
  • gcc/ada/s-interr-vxworks.adb

    diff -urN gcc-4.3.2-orig/gcc/ada/s-interr-vxworks.adb gcc-4.3.2/gcc/ada/s-interr-vxworks.adb
    old new  
    1 ------------------------------------------------------------------------------
    2 --                                                                          --
    3 --                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
    4 --                                                                          --
    5 --                     S Y S T E M . I N T E R R U P T S                    --
    6 --                                                                          --
    7 --                                  B o d y                                 --
    8 --                                                                          --
    9 --         Copyright (C) 1992-2007, Free Software Foundation, Inc.          --
    10 --                                                                          --
    11 -- GNARL is free software; you can  redistribute it  and/or modify it under --
    12 -- terms of the  GNU General Public License as published  by the Free Soft- --
    13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
    14 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
    15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
    16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
    17 -- for  more details.  You should have  received  a copy of the GNU General --
    18 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
    19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
    20 -- Boston, MA 02110-1301, USA.                                              --
    21 --                                                                          --
    22 -- As a special exception,  if other files  instantiate  generics from this --
    23 -- unit, or you link  this unit with other files  to produce an executable, --
    24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
    25 -- covered  by the  GNU  General  Public  License.  This exception does not --
    26 -- however invalidate  any other reasons why  the executable file  might be --
    27 -- covered by the  GNU Public License.                                      --
    28 --                                                                          --
    29 -- GNARL was developed by the GNARL team at Florida State University.       --
    30 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
    31 --                                                                          --
    32 ------------------------------------------------------------------------------
    33 
    34 --  Invariants:
    35 
    36 --  All user-handleable signals are masked at all times in all tasks/threads
    37 --  except possibly for the Interrupt_Manager task.
    38 
    39 --  When a user task wants to have the effect of masking/unmasking an signal,
    40 --  it must call Block_Interrupt/Unblock_Interrupt, which will have the effect
    41 --  of unmasking/masking the signal in the Interrupt_Manager task. These
    42 --  comments do not apply to vectored hardware interrupts, which may be masked
    43 --  or unmasked using routined interfaced to the relevant VxWorks system
    44 --  calls.
    45 
    46 --  Once we associate a Signal_Server_Task with an signal, the task never goes
    47 --  away, and we never remove the association. On the other hand, it is more
    48 --  convenient to terminate an associated Interrupt_Server_Task for a vectored
    49 --  hardware interrupt (since we use a binary semaphore for synchronization
    50 --  with the umbrella handler).
    51 
    52 --  There is no more than one signal per Signal_Server_Task and no more than
    53 --  one Signal_Server_Task per signal. The same relation holds for hardware
    54 --  interrupts and Interrupt_Server_Task's at any given time. That is, only
    55 --  one non-terminated Interrupt_Server_Task exists for a give interrupt at
    56 --  any time.
    57 
    58 --  Within this package, the lock L is used to protect the various status
    59 --  tables. If there is a Server_Task associated with a signal or interrupt,
    60 --  we use the per-task lock of the Server_Task instead so that we protect the
    61 --  status between Interrupt_Manager and Server_Task. Protection among
    62 --  service requests are ensured via user calls to the Interrupt_Manager
    63 --  entries.
    64 
    65 --  This is the VxWorks version of this package, supporting vectored hardware
    66 --  interrupts.
    67 
    68 with Ada.Unchecked_Conversion;
    69 
    70 with System.OS_Interface; use System.OS_Interface;
    71 
    72 with Interfaces.VxWorks;
    73 
    74 with Ada.Task_Identification;
    75 --  used for Task_Id type
    76 
    77 with Ada.Exceptions;
    78 --  used for Raise_Exception
    79 
    80 with System.Interrupt_Management;
    81 --  used for Reserve
    82 
    83 with System.Task_Primitives.Operations;
    84 --  used for Write_Lock
    85 --           Unlock
    86 --           Abort
    87 --           Wakeup_Task
    88 --           Sleep
    89 --           Initialize_Lock
    90 
    91 with System.Storage_Elements;
    92 --  used for To_Address
    93 --           To_Integer
    94 --           Integer_Address
    95 
    96 with System.Tasking.Utilities;
    97 --  used for Make_Independent
    98 
    99 with System.Tasking.Rendezvous;
    100 --  used for Call_Simple
    101 pragma Elaborate_All (System.Tasking.Rendezvous);
    102 
    103 package body System.Interrupts is
    104 
    105    use Tasking;
    106    use Ada.Exceptions;
    107 
    108    package POP renames System.Task_Primitives.Operations;
    109 
    110    function To_Ada is new Ada.Unchecked_Conversion
    111      (System.Tasking.Task_Id, Ada.Task_Identification.Task_Id);
    112 
    113    function To_System is new Ada.Unchecked_Conversion
    114      (Ada.Task_Identification.Task_Id, Task_Id);
    115 
    116    -----------------
    117    -- Local Tasks --
    118    -----------------
    119 
    120    --  WARNING: System.Tasking.Stages performs calls to this task with
    121    --  low-level constructs. Do not change this spec without synchronizing it.
    122 
    123    task Interrupt_Manager is
    124       entry Detach_Interrupt_Entries (T : Task_Id);
    125 
    126       entry Attach_Handler
    127         (New_Handler : Parameterless_Handler;
    128          Interrupt   : Interrupt_ID;
    129          Static      : Boolean;
    130          Restoration : Boolean := False);
    131 
    132       entry Exchange_Handler
    133         (Old_Handler : out Parameterless_Handler;
    134          New_Handler : Parameterless_Handler;
    135          Interrupt   : Interrupt_ID;
    136          Static      : Boolean);
    137 
    138       entry Detach_Handler
    139         (Interrupt : Interrupt_ID;
    140          Static    : Boolean);
    141 
    142       entry Bind_Interrupt_To_Entry
    143         (T         : Task_Id;
    144          E         : Task_Entry_Index;
    145          Interrupt : Interrupt_ID);
    146 
    147       pragma Interrupt_Priority (System.Interrupt_Priority'First);
    148    end Interrupt_Manager;
    149 
    150    task type Interrupt_Server_Task
    151      (Interrupt : Interrupt_ID; Int_Sema : SEM_ID) is
    152       --  Server task for vectored hardware interrupt handling
    153       pragma Interrupt_Priority (System.Interrupt_Priority'First + 2);
    154    end Interrupt_Server_Task;
    155 
    156    type Interrupt_Task_Access is access Interrupt_Server_Task;
    157 
    158    -------------------------------
    159    -- Local Types and Variables --
    160    -------------------------------
    161 
    162    type Entry_Assoc is record
    163       T : Task_Id;
    164       E : Task_Entry_Index;
    165    end record;
    166 
    167    type Handler_Assoc is record
    168       H      : Parameterless_Handler;
    169       Static : Boolean;   --  Indicates static binding;
    170    end record;
    171 
    172    User_Handler : array (Interrupt_ID) of Handler_Assoc :=
    173      (others => (null, Static => False));
    174    pragma Volatile_Components (User_Handler);
    175    --  Holds the protected procedure handler (if any) and its Static
    176    --  information  for each interrupt or signal. A handler is static
    177    --  iff it is specified through the pragma Attach_Handler.
    178 
    179    User_Entry : array (Interrupt_ID) of Entry_Assoc :=
    180      (others => (T => Null_Task, E => Null_Task_Entry));
    181    pragma Volatile_Components (User_Entry);
    182    --  Holds the task and entry index (if any) for each interrupt / signal
    183 
    184    --  Type and Head, Tail of the list containing Registered Interrupt
    185    --  Handlers. These definitions are used to register the handlers
    186    --  specified by the pragma Interrupt_Handler.
    187 
    188    type Registered_Handler;
    189    type R_Link is access all Registered_Handler;
    190 
    191    type Registered_Handler is record
    192       H    : System.Address := System.Null_Address;
    193       Next : R_Link := null;
    194    end record;
    195 
    196    Registered_Handler_Head : R_Link := null;
    197    Registered_Handler_Tail : R_Link := null;
    198 
    199    Server_ID : array (Interrupt_ID) of System.Tasking.Task_Id :=
    200      (others => System.Tasking.Null_Task);
    201    pragma Atomic_Components (Server_ID);
    202    --  Holds the Task_Id of the Server_Task for each interrupt / signal.
    203    --  Task_Id is needed to accomplish locking per interrupt base. Also
    204    --  is needed to determine whether to create a new Server_Task.
    205 
    206    Semaphore_ID_Map : array
    207      (Interrupt_ID range 0 .. System.OS_Interface.Max_HW_Interrupt)
    208       of SEM_ID := (others => 0);
    209    --  Array of binary semaphores associated with vectored interrupts
    210    --  Note that the last bound should be Max_HW_Interrupt, but this will raise
    211    --  Storage_Error if Num_HW_Interrupts is null, so use an extra 4 bytes
    212    --  instead.
    213 
    214    Interrupt_Access_Hold : Interrupt_Task_Access;
    215    --  Variable for allocating an Interrupt_Server_Task
    216 
    217    Default_Handler : array (HW_Interrupt) of Interfaces.VxWorks.VOIDFUNCPTR;
    218    --  Vectored interrupt handlers installed prior to program startup.
    219    --  These are saved only when the umbrella handler is installed for
    220    --  a given interrupt number.
    221 
    222    -----------------------
    223    -- Local Subprograms --
    224    -----------------------
    225 
    226    procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID);
    227    --  Check if Id is a reserved interrupt, and if so raise Program_Error
    228    --  with an appropriate message, otherwise return.
    229 
    230    procedure Finalize_Interrupt_Servers;
    231    --  Unbind the handlers for hardware interrupt server tasks at program
    232    --  termination.
    233 
    234    function Is_Registered (Handler : Parameterless_Handler) return Boolean;
    235    --  See if Handler has been "pragma"ed using Interrupt_Handler.
    236    --  Always consider a null handler as registered.
    237 
    238    procedure Notify_Interrupt (Param : System.Address);
    239    --  Umbrella handler for vectored interrupts (not signals)
    240 
    241    procedure Install_Default_Action (Interrupt : HW_Interrupt);
    242    --  Restore a handler that was in place prior to program execution
    243 
    244    procedure Install_Umbrella_Handler
    245      (Interrupt : HW_Interrupt;
    246       Handler   : Interfaces.VxWorks.VOIDFUNCPTR);
    247    --  Install the runtime umbrella handler for a vectored hardware
    248    --  interrupt
    249 
    250    procedure Unimplemented (Feature : String);
    251    pragma No_Return (Unimplemented);
    252    --  Used to mark a call to an unimplemented function. Raises Program_Error
    253    --  with an appropriate message noting that Feature is unimplemented.
    254 
    255    --------------------
    256    -- Attach_Handler --
    257    --------------------
    258 
    259    --  Calling this procedure with New_Handler = null and Static = True
    260    --  means we want to detach the current handler regardless of the
    261    --  previous handler's binding status (ie. do not care if it is a
    262    --  dynamic or static handler).
    263 
    264    --  This option is needed so that during the finalization of a PO, we
    265    --  can detach handlers attached through pragma Attach_Handler.
    266 
    267    procedure Attach_Handler
    268      (New_Handler : Parameterless_Handler;
    269       Interrupt   : Interrupt_ID;
    270       Static      : Boolean := False) is
    271    begin
    272       Check_Reserved_Interrupt (Interrupt);
    273       Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static);
    274    end Attach_Handler;
    275 
    276    -----------------------------
    277    -- Bind_Interrupt_To_Entry --
    278    -----------------------------
    279 
    280    --  This procedure raises a Program_Error if it tries to
    281    --  bind an interrupt to which an Entry or a Procedure is
    282    --  already bound.
    283 
    284    procedure Bind_Interrupt_To_Entry
    285      (T       : Task_Id;
    286       E       : Task_Entry_Index;
    287       Int_Ref : System.Address)
    288    is
    289       Interrupt : constant Interrupt_ID :=
    290         Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
    291 
    292    begin
    293       Check_Reserved_Interrupt (Interrupt);
    294       Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
    295    end Bind_Interrupt_To_Entry;
    296 
    297    ---------------------
    298    -- Block_Interrupt --
    299    ---------------------
    300 
    301    procedure Block_Interrupt (Interrupt : Interrupt_ID) is
    302    begin
    303       Unimplemented ("Block_Interrupt");
    304    end Block_Interrupt;
    305 
    306    ------------------------------
    307    -- Check_Reserved_Interrupt --
    308    ------------------------------
    309 
    310    procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID) is
    311    begin
    312       if Is_Reserved (Interrupt) then
    313          Raise_Exception
    314            (Program_Error'Identity,
    315             "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved");
    316       else
    317          return;
    318       end if;
    319    end Check_Reserved_Interrupt;
    320 
    321    ---------------------
    322    -- Current_Handler --
    323    ---------------------
    324 
    325    function Current_Handler
    326      (Interrupt : Interrupt_ID) return Parameterless_Handler
    327    is
    328    begin
    329       Check_Reserved_Interrupt (Interrupt);
    330 
    331       --  ??? Since Parameterless_Handler is not Atomic, the
    332       --  current implementation is wrong. We need a new service in
    333       --  Interrupt_Manager to ensure atomicity.
    334 
    335       return User_Handler (Interrupt).H;
    336    end Current_Handler;
    337 
    338    --------------------
    339    -- Detach_Handler --
    340    --------------------
    341 
    342    --  Calling this procedure with Static = True means we want to Detach the
    343    --  current handler regardless of the previous handler's binding status
    344    --  (i.e. do not care if it is a dynamic or static handler).
    345 
    346    --  This option is needed so that during the finalization of a PO, we can
    347    --  detach handlers attached through pragma Attach_Handler.
    348 
    349    procedure Detach_Handler
    350      (Interrupt : Interrupt_ID;
    351       Static    : Boolean := False) is
    352    begin
    353       Check_Reserved_Interrupt (Interrupt);
    354       Interrupt_Manager.Detach_Handler (Interrupt, Static);
    355    end Detach_Handler;
    356 
    357    ------------------------------
    358    -- Detach_Interrupt_Entries --
    359    ------------------------------
    360 
    361    procedure Detach_Interrupt_Entries (T : Task_Id) is
    362    begin
    363       Interrupt_Manager.Detach_Interrupt_Entries (T);
    364    end Detach_Interrupt_Entries;
    365 
    366    ----------------------
    367    -- Exchange_Handler --
    368    ----------------------
    369 
    370    --  Calling this procedure with New_Handler = null and Static = True
    371    --  means we want to detach the current handler regardless of the
    372    --  previous handler's binding status (ie. do not care if it is a
    373    --  dynamic or static handler).
    374 
    375    --  This option is needed so that during the finalization of a PO, we
    376    --  can detach handlers attached through pragma Attach_Handler.
    377 
    378    procedure Exchange_Handler
    379      (Old_Handler : out Parameterless_Handler;
    380       New_Handler : Parameterless_Handler;
    381       Interrupt   : Interrupt_ID;
    382       Static      : Boolean := False)
    383    is
    384    begin
    385       Check_Reserved_Interrupt (Interrupt);
    386       Interrupt_Manager.Exchange_Handler
    387         (Old_Handler, New_Handler, Interrupt, Static);
    388    end Exchange_Handler;
    389 
    390    --------------
    391    -- Finalize --
    392    --------------
    393 
    394    procedure Finalize (Object : in out Static_Interrupt_Protection) is
    395    begin
    396       --  ??? loop to be executed only when we're not doing library level
    397       --  finalization, since in this case all interrupt / signal tasks are
    398       --  gone.
    399 
    400       if not Interrupt_Manager'Terminated then
    401          for N in reverse Object.Previous_Handlers'Range loop
    402             Interrupt_Manager.Attach_Handler
    403               (New_Handler => Object.Previous_Handlers (N).Handler,
    404                Interrupt   => Object.Previous_Handlers (N).Interrupt,
    405                Static      => Object.Previous_Handlers (N).Static,
    406                Restoration => True);
    407          end loop;
    408       end if;
    409 
    410       Tasking.Protected_Objects.Entries.Finalize
    411         (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
    412    end Finalize;
    413 
    414    --------------------------------
    415    -- Finalize_Interrupt_Servers --
    416    --------------------------------
    417 
    418    --  Restore default handlers for interrupt servers
    419 
    420    --  This is called by the Interrupt_Manager task when it receives the abort
    421    --  signal during program finalization.
    422 
    423    procedure Finalize_Interrupt_Servers is
    424       HW_Interrupts : constant Boolean := HW_Interrupt'Last >= 0;
    425 
    426    begin
    427       if HW_Interrupts then
    428          for Int in HW_Interrupt loop
    429             if Server_ID (Interrupt_ID (Int)) /= null
    430               and then
    431                 not Ada.Task_Identification.Is_Terminated
    432                  (To_Ada (Server_ID (Interrupt_ID (Int))))
    433             then
    434                Interrupt_Manager.Attach_Handler
    435                  (New_Handler => null,
    436                   Interrupt => Interrupt_ID (Int),
    437                   Static => True,
    438                   Restoration => True);
    439             end if;
    440          end loop;
    441       end if;
    442    end Finalize_Interrupt_Servers;
    443 
    444    -------------------------------------
    445    -- Has_Interrupt_Or_Attach_Handler --
    446    -------------------------------------
    447 
    448    function Has_Interrupt_Or_Attach_Handler
    449      (Object : access Dynamic_Interrupt_Protection)
    450       return   Boolean
    451    is
    452       pragma Unreferenced (Object);
    453    begin
    454       return True;
    455    end Has_Interrupt_Or_Attach_Handler;
    456 
    457    function Has_Interrupt_Or_Attach_Handler
    458      (Object : access Static_Interrupt_Protection)
    459       return   Boolean
    460    is
    461       pragma Unreferenced (Object);
    462    begin
    463       return True;
    464    end Has_Interrupt_Or_Attach_Handler;
    465 
    466    ----------------------
    467    -- Ignore_Interrupt --
    468    ----------------------
    469 
    470    procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
    471    begin
    472       Unimplemented ("Ignore_Interrupt");
    473    end Ignore_Interrupt;
    474 
    475    ----------------------------
    476    -- Install_Default_Action --
    477    ----------------------------
    478 
    479    procedure Install_Default_Action (Interrupt : HW_Interrupt) is
    480    begin
    481       --  Restore original interrupt handler
    482 
    483       Interfaces.VxWorks.intVecSet
    484         (Interfaces.VxWorks.INUM_TO_IVEC (Integer (Interrupt)),
    485          Default_Handler (Interrupt));
    486       Default_Handler (Interrupt) := null;
    487    end Install_Default_Action;
    488 
    489    ----------------------
    490    -- Install_Handlers --
    491    ----------------------
    492 
    493    procedure Install_Handlers
    494      (Object       : access Static_Interrupt_Protection;
    495       New_Handlers : New_Handler_Array)
    496    is
    497    begin
    498       for N in New_Handlers'Range loop
    499 
    500          --  We need a lock around this ???
    501 
    502          Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
    503          Object.Previous_Handlers (N).Static    := User_Handler
    504            (New_Handlers (N).Interrupt).Static;
    505 
    506          --  We call Exchange_Handler and not directly Interrupt_Manager.
    507          --  Exchange_Handler so we get the Is_Reserved check.
    508 
    509          Exchange_Handler
    510            (Old_Handler => Object.Previous_Handlers (N).Handler,
    511             New_Handler => New_Handlers (N).Handler,
    512             Interrupt   => New_Handlers (N).Interrupt,
    513             Static      => True);
    514       end loop;
    515    end Install_Handlers;
    516 
    517    ------------------------------
    518    -- Install_Umbrella_Handler --
    519    ------------------------------
    520 
    521    procedure Install_Umbrella_Handler
    522      (Interrupt : HW_Interrupt;
    523       Handler   : Interfaces.VxWorks.VOIDFUNCPTR)
    524    is
    525       use Interfaces.VxWorks;
    526 
    527       Vec : constant Interrupt_Vector :=
    528               INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt));
    529 
    530       Old_Handler : constant VOIDFUNCPTR :=
    531                       intVecGet
    532                         (INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt)));
    533 
    534       Stat : Interfaces.VxWorks.STATUS;
    535       pragma Unreferenced (Stat);
    536       --  ??? shouldn't we test Stat at least in a pragma Assert?
    537 
    538    begin
    539       --  Only install umbrella handler when no Ada handler has already been
    540       --  installed. Note that the interrupt number is passed as a parameter
    541       --  when an interrupt occurs, so the umbrella handler has a different
    542       --  wrapper generated by intConnect for each interrupt number.
    543 
    544       if Default_Handler (Interrupt) = null then
    545          Stat :=
    546            intConnect (Vec, Handler, System.Address (Interrupt));
    547          Default_Handler (Interrupt) := Old_Handler;
    548       end if;
    549    end Install_Umbrella_Handler;
    550 
    551    ----------------
    552    -- Is_Blocked --
    553    ----------------
    554 
    555    function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
    556    begin
    557       Unimplemented ("Is_Blocked");
    558       return False;
    559    end Is_Blocked;
    560 
    561    -----------------------
    562    -- Is_Entry_Attached --
    563    -----------------------
    564 
    565    function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
    566    begin
    567       Check_Reserved_Interrupt (Interrupt);
    568       return User_Entry (Interrupt).T /= Null_Task;
    569    end Is_Entry_Attached;
    570 
    571    -------------------------
    572    -- Is_Handler_Attached --
    573    -------------------------
    574 
    575    function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
    576    begin
    577       Check_Reserved_Interrupt (Interrupt);
    578       return User_Handler (Interrupt).H /= null;
    579    end Is_Handler_Attached;
    580 
    581    ----------------
    582    -- Is_Ignored --
    583    ----------------
    584 
    585    function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
    586    begin
    587       Unimplemented ("Is_Ignored");
    588       return False;
    589    end Is_Ignored;
    590 
    591    -------------------
    592    -- Is_Registered --
    593    -------------------
    594 
    595    function Is_Registered (Handler : Parameterless_Handler) return Boolean is
    596       type Fat_Ptr is record
    597          Object_Addr  : System.Address;
    598          Handler_Addr : System.Address;
    599       end record;
    600 
    601       function To_Fat_Ptr is new Ada.Unchecked_Conversion
    602         (Parameterless_Handler, Fat_Ptr);
    603 
    604       Ptr : R_Link;
    605       Fat : Fat_Ptr;
    606 
    607    begin
    608       if Handler = null then
    609          return True;
    610       end if;
    611 
    612       Fat := To_Fat_Ptr (Handler);
    613 
    614       Ptr := Registered_Handler_Head;
    615 
    616       while Ptr /= null loop
    617          if Ptr.H = Fat.Handler_Addr then
    618             return True;
    619          end if;
    620 
    621          Ptr := Ptr.Next;
    622       end loop;
    623 
    624       return False;
    625    end Is_Registered;
    626 
    627    -----------------
    628    -- Is_Reserved --
    629    -----------------
    630 
    631    function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
    632       use System.Interrupt_Management;
    633    begin
    634       return Reserve (System.Interrupt_Management.Interrupt_ID (Interrupt));
    635    end Is_Reserved;
    636 
    637    ----------------------
    638    -- Notify_Interrupt --
    639    ----------------------
    640 
    641    --  Umbrella handler for vectored hardware interrupts (as opposed to
    642    --  signals and exceptions).  As opposed to the signal implementation,
    643    --  this handler is only installed in the vector table while there is
    644    --  an active association of an Ada handler to the interrupt.
    645 
    646    --  Otherwise, the handler that existed prior to program startup is
    647    --  in the vector table.  This ensures that handlers installed by
    648    --  the BSP are active unless explicitly replaced in the program text.
    649 
    650    --  Each Interrupt_Server_Task has an associated binary semaphore
    651    --  on which it pends once it's been started.  This routine determines
    652    --  The appropriate semaphore and and issues a semGive call, waking
    653    --  the server task.  When a handler is unbound,
    654    --  System.Interrupts.Unbind_Handler issues a semFlush, and the
    655    --  server task deletes its semaphore and terminates.
    656 
    657    procedure Notify_Interrupt (Param : System.Address) is
    658       Interrupt : constant Interrupt_ID := Interrupt_ID (Param);
    659 
    660       Discard_Result : STATUS;
    661       pragma Unreferenced (Discard_Result);
    662 
    663    begin
    664       Discard_Result := semGive (Semaphore_ID_Map (Interrupt));
    665    end Notify_Interrupt;
    666 
    667    ---------------
    668    -- Reference --
    669    ---------------
    670 
    671    function Reference (Interrupt : Interrupt_ID) return System.Address is
    672    begin
    673       Check_Reserved_Interrupt (Interrupt);
    674       return Storage_Elements.To_Address
    675         (Storage_Elements.Integer_Address (Interrupt));
    676    end Reference;
    677 
    678    --------------------------------
    679    -- Register_Interrupt_Handler --
    680    --------------------------------
    681 
    682    procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
    683       New_Node_Ptr : R_Link;
    684 
    685    begin
    686       --  This routine registers a handler as usable for dynamic
    687       --  interrupt handler association. Routines attaching and detaching
    688       --  handlers dynamically should determine whether the handler is
    689       --  registered. Program_Error should be raised if it is not registered.
    690 
    691       --  Pragma Interrupt_Handler can only appear in a library
    692       --  level PO definition and instantiation. Therefore, we do not need
    693       --  to implement an unregister operation. Nor do we need to
    694       --  protect the queue structure with a lock.
    695 
    696       pragma Assert (Handler_Addr /= System.Null_Address);
    697 
    698       New_Node_Ptr := new Registered_Handler;
    699       New_Node_Ptr.H := Handler_Addr;
    700 
    701       if Registered_Handler_Head = null then
    702          Registered_Handler_Head := New_Node_Ptr;
    703          Registered_Handler_Tail := New_Node_Ptr;
    704 
    705       else
    706          Registered_Handler_Tail.Next := New_Node_Ptr;
    707          Registered_Handler_Tail := New_Node_Ptr;
    708       end if;
    709    end Register_Interrupt_Handler;
    710 
    711    -----------------------
    712    -- Unblock_Interrupt --
    713    -----------------------
    714 
    715    procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
    716    begin
    717       Unimplemented ("Unblock_Interrupt");
    718    end Unblock_Interrupt;
    719 
    720    ------------------
    721    -- Unblocked_By --
    722    ------------------
    723 
    724    function Unblocked_By
    725      (Interrupt : Interrupt_ID) return System.Tasking.Task_Id
    726    is
    727    begin
    728       Unimplemented ("Unblocked_By");
    729       return Null_Task;
    730    end Unblocked_By;
    731 
    732    ------------------------
    733    -- Unignore_Interrupt --
    734    ------------------------
    735 
    736    procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
    737    begin
    738       Unimplemented ("Unignore_Interrupt");
    739    end Unignore_Interrupt;
    740 
    741    -------------------
    742    -- Unimplemented --
    743    -------------------
    744 
    745    procedure Unimplemented (Feature : String) is
    746    begin
    747       Raise_Exception
    748         (Program_Error'Identity,
    749          Feature & " not implemented on VxWorks");
    750    end Unimplemented;
    751 
    752    -----------------------
    753    -- Interrupt_Manager --
    754    -----------------------
    755 
    756    task body Interrupt_Manager is
    757 
    758       --------------------
    759       -- Local Routines --
    760       --------------------
    761 
    762       procedure Bind_Handler (Interrupt : Interrupt_ID);
    763       --  This procedure does not do anything if a signal is blocked.
    764       --  Otherwise, we have to interrupt Server_Task for status change through
    765       --  a wakeup signal.
    766 
    767       procedure Unbind_Handler (Interrupt : Interrupt_ID);
    768       --  This procedure does not do anything if a signal is blocked.
    769       --  Otherwise, we have to interrupt Server_Task for status change
    770       --  through an abort signal.
    771 
    772       procedure Unprotected_Exchange_Handler
    773         (Old_Handler : out Parameterless_Handler;
    774          New_Handler : Parameterless_Handler;
    775          Interrupt   : Interrupt_ID;
    776          Static      : Boolean;
    777          Restoration : Boolean := False);
    778 
    779       procedure Unprotected_Detach_Handler
    780         (Interrupt : Interrupt_ID;
    781          Static    : Boolean);
    782 
    783       ------------------
    784       -- Bind_Handler --
    785       ------------------
    786 
    787       procedure Bind_Handler (Interrupt : Interrupt_ID) is
    788       begin
    789          Install_Umbrella_Handler
    790            (HW_Interrupt (Interrupt), Notify_Interrupt'Access);
    791       end Bind_Handler;
    792 
    793       --------------------
    794       -- Unbind_Handler --
    795       --------------------
    796 
    797       procedure Unbind_Handler (Interrupt : Interrupt_ID) is
    798          S : STATUS;
    799          use type STATUS;
    800 
    801       begin
    802          --  Hardware interrupt
    803 
    804          Install_Default_Action (HW_Interrupt (Interrupt));
    805 
    806          --  Flush server task off semaphore, allowing it to terminate
    807 
    808          S := semFlush (Semaphore_ID_Map (Interrupt));
    809          pragma Assert (S = 0);
    810       end Unbind_Handler;
    811 
    812       --------------------------------
    813       -- Unprotected_Detach_Handler --
    814       --------------------------------
    815 
    816       procedure Unprotected_Detach_Handler
    817         (Interrupt : Interrupt_ID;
    818          Static    : Boolean)
    819       is
    820          Old_Handler : Parameterless_Handler;
    821       begin
    822          if User_Entry (Interrupt).T /= Null_Task then
    823             --  If an interrupt entry is installed raise
    824             --  Program_Error. (propagate it to the caller).
    825 
    826             Raise_Exception (Program_Error'Identity,
    827               "An interrupt entry is already installed");
    828          end if;
    829 
    830          --  Note : Static = True will pass the following check. This is the
    831          --  case when we want to detach a handler regardless of the static
    832          --  status of the Current_Handler.
    833 
    834          if not Static and then User_Handler (Interrupt).Static then
    835 
    836             --  Trying to detach a static Interrupt Handler. raise
    837             --  Program_Error.
    838 
    839             Raise_Exception (Program_Error'Identity,
    840               "Trying to detach a static Interrupt Handler");
    841          end if;
    842 
    843          Old_Handler := User_Handler (Interrupt).H;
    844 
    845          --  The new handler
    846 
    847          User_Handler (Interrupt).H := null;
    848          User_Handler (Interrupt).Static := False;
    849 
    850          if Old_Handler /= null then
    851             Unbind_Handler (Interrupt);
    852          end if;
    853       end Unprotected_Detach_Handler;
    854 
    855       ----------------------------------
    856       -- Unprotected_Exchange_Handler --
    857       ----------------------------------
    858 
    859       procedure Unprotected_Exchange_Handler
    860         (Old_Handler : out Parameterless_Handler;
    861          New_Handler : Parameterless_Handler;
    862          Interrupt   : Interrupt_ID;
    863          Static      : Boolean;
    864          Restoration : Boolean := False)
    865       is
    866       begin
    867          if User_Entry (Interrupt).T /= Null_Task then
    868 
    869             --  If an interrupt entry is already installed, raise
    870             --  Program_Error. (propagate it to the caller).
    871 
    872             Raise_Exception
    873               (Program_Error'Identity,
    874                "An interrupt is already installed");
    875          end if;
    876 
    877          --  Note : A null handler with Static = True will
    878          --  pass the following check. This is the case when we want to
    879          --  detach a handler regardless of the Static status
    880          --  of Current_Handler.
    881          --  We don't check anything if Restoration is True, since we
    882          --  may be detaching a static handler to restore a dynamic one.
    883 
    884          if not Restoration and then not Static
    885            and then (User_Handler (Interrupt).Static
    886 
    887             --  Trying to overwrite a static Interrupt Handler with a
    888             --  dynamic Handler
    889 
    890             --  The new handler is not specified as an
    891             --  Interrupt Handler by a pragma.
    892 
    893            or else not Is_Registered (New_Handler))
    894          then
    895             Raise_Exception
    896               (Program_Error'Identity,
    897                "Trying to overwrite a static Interrupt Handler with a " &
    898                "dynamic Handler");
    899          end if;
    900 
    901          --  Save the old handler
    902 
    903          Old_Handler := User_Handler (Interrupt).H;
    904 
    905          --  The new handler
    906 
    907          User_Handler (Interrupt).H := New_Handler;
    908 
    909          if New_Handler = null then
    910 
    911             --  The null handler means we are detaching the handler
    912 
    913             User_Handler (Interrupt).Static := False;
    914 
    915          else
    916             User_Handler (Interrupt).Static := Static;
    917          end if;
    918 
    919          --  Invoke a corresponding Server_Task if not yet created.
    920          --  Place Task_Id info in Server_ID array.
    921 
    922          if New_Handler /= null
    923            and then
    924             (Server_ID (Interrupt) = Null_Task
    925               or else
    926                 Ada.Task_Identification.Is_Terminated
    927                   (To_Ada (Server_ID (Interrupt))))
    928          then
    929             Interrupt_Access_Hold :=
    930               new Interrupt_Server_Task
    931                 (Interrupt, semBCreate (SEM_Q_FIFO, SEM_EMPTY));
    932             Server_ID (Interrupt) :=
    933               To_System (Interrupt_Access_Hold.all'Identity);
    934          end if;
    935 
    936          if (New_Handler = null) and then Old_Handler /= null then
    937 
    938             --  Restore default handler
    939 
    940             Unbind_Handler (Interrupt);
    941 
    942          elsif Old_Handler = null then
    943 
    944             --  Save default handler
    945 
    946             Bind_Handler (Interrupt);
    947          end if;
    948       end Unprotected_Exchange_Handler;
    949 
    950       --  Start of processing for Interrupt_Manager
    951 
    952    begin
    953       --  By making this task independent of any master, when the process
    954       --  goes away, the Interrupt_Manager will terminate gracefully.
    955 
    956       System.Tasking.Utilities.Make_Independent;
    957 
    958       loop
    959          --  A block is needed to absorb Program_Error exception
    960 
    961          declare
    962             Old_Handler : Parameterless_Handler;
    963 
    964          begin
    965             select
    966                accept Attach_Handler
    967                  (New_Handler : Parameterless_Handler;
    968                   Interrupt   : Interrupt_ID;
    969                   Static      : Boolean;
    970                   Restoration : Boolean := False)
    971                do
    972                   Unprotected_Exchange_Handler
    973                     (Old_Handler, New_Handler, Interrupt, Static, Restoration);
    974                end Attach_Handler;
    975 
    976             or
    977                accept Exchange_Handler
    978                  (Old_Handler : out Parameterless_Handler;
    979                   New_Handler : Parameterless_Handler;
    980                   Interrupt   : Interrupt_ID;
    981                   Static      : Boolean)
    982                do
    983                   Unprotected_Exchange_Handler
    984                     (Old_Handler, New_Handler, Interrupt, Static);
    985                end Exchange_Handler;
    986 
    987             or
    988                accept Detach_Handler
    989                   (Interrupt   : Interrupt_ID;
    990                    Static      : Boolean)
    991                do
    992                   Unprotected_Detach_Handler (Interrupt, Static);
    993                end Detach_Handler;
    994             or
    995                accept Bind_Interrupt_To_Entry
    996                  (T       : Task_Id;
    997                   E       : Task_Entry_Index;
    998                   Interrupt : Interrupt_ID)
    999                do
    1000                   --  If there is a binding already (either a procedure or an
    1001                   --  entry), raise Program_Error (propagate it to the caller).
    1002 
    1003                   if User_Handler (Interrupt).H /= null
    1004                     or else User_Entry (Interrupt).T /= Null_Task
    1005                   then
    1006                      Raise_Exception
    1007                        (Program_Error'Identity,
    1008                         "A binding for this interrupt is already present");
    1009                   end if;
    1010 
    1011                   User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E);
    1012 
    1013                   --  Indicate the attachment of interrupt entry in the ATCB.
    1014                   --  This is needed so when an interrupt entry task terminates
    1015                   --  the binding can be cleaned. The call to unbinding must be
    1016                   --  make by the task before it terminates.
    1017 
    1018                   T.Interrupt_Entry := True;
    1019 
    1020                   --  Invoke a corresponding Server_Task if not yet created.
    1021                   --  Place Task_Id info in Server_ID array.
    1022 
    1023                   if Server_ID (Interrupt) = Null_Task
    1024                     or else
    1025                       Ada.Task_Identification.Is_Terminated
    1026                         (To_Ada (Server_ID (Interrupt)))
    1027                   then
    1028                      Interrupt_Access_Hold := new Interrupt_Server_Task
    1029                        (Interrupt, semBCreate (SEM_Q_FIFO, SEM_EMPTY));
    1030                      Server_ID (Interrupt) :=
    1031                        To_System (Interrupt_Access_Hold.all'Identity);
    1032                   end if;
    1033 
    1034                   Bind_Handler (Interrupt);
    1035                end Bind_Interrupt_To_Entry;
    1036 
    1037             or
    1038                accept Detach_Interrupt_Entries (T : Task_Id) do
    1039                   for Int in Interrupt_ID'Range loop
    1040                      if not Is_Reserved (Int) then
    1041                         if User_Entry (Int).T = T then
    1042                            User_Entry (Int) :=
    1043                              Entry_Assoc'
    1044                                (T => Null_Task, E => Null_Task_Entry);
    1045                            Unbind_Handler (Int);
    1046                         end if;
    1047                      end if;
    1048                   end loop;
    1049 
    1050                   --  Indicate in ATCB that no interrupt entries are attached
    1051 
    1052                   T.Interrupt_Entry := False;
    1053                end Detach_Interrupt_Entries;
    1054             end select;
    1055 
    1056          exception
    1057             --  If there is a Program_Error we just want to propagate it to
    1058             --  the caller and do not want to stop this task.
    1059 
    1060             when Program_Error =>
    1061                null;
    1062 
    1063             when others =>
    1064                pragma Assert (False);
    1065                null;
    1066          end;
    1067       end loop;
    1068 
    1069    exception
    1070       when Standard'Abort_Signal =>
    1071          --  Flush interrupt server semaphores, so they can terminate
    1072          Finalize_Interrupt_Servers;
    1073          raise;
    1074    end Interrupt_Manager;
    1075 
    1076    ---------------------------
    1077    -- Interrupt_Server_Task --
    1078    ---------------------------
    1079 
    1080    --  Server task for vectored hardware interrupt handling
    1081 
    1082    task body Interrupt_Server_Task is
    1083       Self_Id         : constant Task_Id := Self;
    1084       Tmp_Handler     : Parameterless_Handler;
    1085       Tmp_ID          : Task_Id;
    1086       Tmp_Entry_Index : Task_Entry_Index;
    1087       S               : STATUS;
    1088 
    1089       use type STATUS;
    1090 
    1091    begin
    1092       System.Tasking.Utilities.Make_Independent;
    1093       Semaphore_ID_Map (Interrupt) := Int_Sema;
    1094 
    1095       loop
    1096          --  Pend on semaphore that will be triggered by the
    1097          --  umbrella handler when the associated interrupt comes in
    1098 
    1099          S := semTake (Int_Sema, WAIT_FOREVER);
    1100          pragma Assert (S = 0);
    1101 
    1102          if User_Handler (Interrupt).H /= null then
    1103 
    1104             --  Protected procedure handler
    1105 
    1106             Tmp_Handler := User_Handler (Interrupt).H;
    1107             Tmp_Handler.all;
    1108 
    1109          elsif User_Entry (Interrupt).T /= Null_Task then
    1110 
    1111             --  Interrupt entry handler
    1112 
    1113             Tmp_ID := User_Entry (Interrupt).T;
    1114             Tmp_Entry_Index := User_Entry (Interrupt).E;
    1115             System.Tasking.Rendezvous.Call_Simple
    1116               (Tmp_ID, Tmp_Entry_Index, System.Null_Address);
    1117 
    1118          else
    1119             --  Semaphore has been flushed by an unbind operation in
    1120             --  the Interrupt_Manager. Terminate the server task.
    1121 
    1122             --  Wait for the Interrupt_Manager to complete its work
    1123 
    1124             POP.Write_Lock (Self_Id);
    1125 
    1126             --  Delete the associated semaphore
    1127 
    1128             S := semDelete (Int_Sema);
    1129 
    1130             pragma Assert (S = 0);
    1131 
    1132             --  Set status for the Interrupt_Manager
    1133 
    1134             Semaphore_ID_Map (Interrupt) := 0;
    1135             Server_ID (Interrupt) := Null_Task;
    1136             POP.Unlock (Self_Id);
    1137 
    1138             exit;
    1139          end if;
    1140       end loop;
    1141    end Interrupt_Server_Task;
    1142 
    1143 begin
    1144    --  Get Interrupt_Manager's ID so that Abort_Interrupt can be sent
    1145 
    1146    Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
    1147 end System.Interrupts;
  • gcc/ada/s-osinte-rtems.ads

    diff -urN gcc-4.3.2-orig/gcc/ada/s-osinte-rtems.ads gcc-4.3.2/gcc/ada/s-osinte-rtems.ads
    old new  
    3737
    3838--  This is the RTEMS version of this package
    3939
    40 --  These are guesses based on what I think the GNARL team will want to
    41 --  call the rtems configurations.  We use CPU-rtems for the rtems
    42 --  configurations.
     40--
     41--  RTEMS target names are of the form CPU-rtems.
     42--  This implementation is designed to work on ALL RTEMS targets.
     43--  The RTEMS implementation is primarily based upon the POSIX threads
     44--  API but there are also bindings to GNAT/RTEMS support routines
     45--  to insulate this code from C API specific details and, in some
     46--  cases, obtain target architecture and BSP specific information
     47--  that is unavailable at the time this package is built.
    4348
    4449--  This package encapsulates all direct interfaces to OS services
    4550--  that are needed by children of System.
    4651
    4752--  PLEASE DO NOT add any with-clauses to this package
    48 --  or remove the pragma Elaborate_Body.
     53--  or remove the pragma Preelaborate.
    4954--  It is designed to be a bottom-level (leaf) package.
    5055
    5156with Interfaces.C;
     
    8489   -- Signals --
    8590   -------------
    8691
    87    Max_Interrupt : constant := 31;
     92   Num_HW_Interrupts : constant := 256;
     93
     94   Max_HW_Interrupt : constant := Num_HW_Interrupts - 1;
     95   type HW_Interrupt is new int range 0 .. Max_HW_Interrupt;
     96
     97   Max_Interrupt : constant := Max_HW_Interrupt;
     98
    8899   type Signal is new int range 0 .. Max_Interrupt;
    89100
    90101   SIGXCPU     : constant := 0; --  XCPU
     
    475486      destructor : destructor_pointer) return int;
    476487   pragma Import (C, pthread_key_create, "pthread_key_create");
    477488
     489   ------------------------------------------------------------
     490   --   Binary Semaphore Wrapper to Support Interrupt Tasks  --
     491   ------------------------------------------------------------
     492
     493   type Binary_Semaphore_Id is new rtems_id;
     494
     495   function Binary_Semaphore_Create return Binary_Semaphore_Id;
     496   pragma Import (
     497      C,
     498      Binary_Semaphore_Create,
     499      "__gnat_binary_semaphore_create");
     500
     501   function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int;
     502   pragma Import (
     503      C,
     504      Binary_Semaphore_Delete,
     505      "__gnat_binary_semaphore_delete");
     506
     507   function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int;
     508   pragma Import (
     509      C,
     510      Binary_Semaphore_Obtain,
     511      "__gnat_binary_semaphore_obtain");
     512
     513   function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int;
     514   pragma Import (
     515      C,
     516      Binary_Semaphore_Release,
     517      "__gnat_binary_semaphore_release");
     518
     519   function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int;
     520   pragma Import (
     521      C,
     522      Binary_Semaphore_Flush,
     523      "__gnat_binary_semaphore_flush");
     524
     525   ------------------------------------------------------------
     526   -- Hardware Interrupt Wrappers to Support Interrupt Tasks --
     527   ------------------------------------------------------------
     528
     529   type Interrupt_Handler is access procedure (parameter : System.Address);
     530   pragma Convention (C, Interrupt_Handler);
     531   type Interrupt_Vector is new System.Address;
     532
     533   function Interrupt_Connect
     534     (Vector    : Interrupt_Vector;
     535      Handler   : Interrupt_Handler;
     536      Parameter : System.Address := System.Null_Address) return int;
     537   pragma Import (C, Interrupt_Connect, "__gnat_interrupt_connect");
     538   --  Use this to set up an user handler. The routine installs a
     539   --  a user handler which is invoked after RTEMS has saved enough
     540   --  context for a high-level language routine to be safely invoked.
     541
     542   function Interrupt_Vector_Get
     543     (Vector : Interrupt_Vector) return Interrupt_Handler;
     544   pragma Import (C, Interrupt_Vector_Get, "__gnat_interrupt_get");
     545   --  Use this to get the existing handler for later restoral.
     546
     547   procedure Interrupt_Vector_Set
     548     (Vector  : Interrupt_Vector;
     549      Handler : Interrupt_Handler);
     550   pragma Import (C, Interrupt_Vector_Set, "__gnat_interrupt_set");
     551   --  Use this to restore a handler obtained using Interrupt_Vector_Get.
     552
     553   function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector;
     554   --  Convert a logical interrupt number to the hardware interrupt vector
     555   --  number used to connect the interrupt.
     556   pragma Import (
     557      C,
     558      Interrupt_Number_To_Vector,
     559      "__gnat_interrupt_number_to_vector"
     560   );
     561
    478562private
    479563
    480564   type sigset_t is new int;
     
    507591      schedpolicy     : int;
    508592      schedparam      : struct_sched_param;
    509593      cputime_clocked_allowed : int;
    510       deatchstate     : int;
     594      detatchstate    : int;
    511595   end record;
    512596   pragma Convention (C, pthread_attr_t);
    513597
    514598   type pthread_condattr_t is record
    515       flags        : int;
     599      is_initialized  : int;
     600      process_shared  : int;
    516601   end record;
    517602   pragma Convention (C, pthread_condattr_t);
    518603
  • gcc/ada/s-osinte-vxworks.adb

    diff -urN gcc-4.3.2-orig/gcc/ada/s-osinte-vxworks.adb gcc-4.3.2/gcc/ada/s-osinte-vxworks.adb
    old new  
    239239      return int (Ticks);
    240240   end To_Clock_Ticks;
    241241
     242   -----------------------------
     243   -- Binary_Semaphore_Create --
     244   -----------------------------
     245
     246   function Binary_Semaphore_Create return Binary_Semaphore_Id is
     247   begin
     248      return semBCreate (SEM_Q_FIFO, SEM_EMPTY);
     249   end Binary_Semaphore_Create;
     250
     251   -----------------------------
     252   -- Binary_Semaphore_Delete --
     253   -----------------------------
     254
     255   function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int is
     256   begin
     257      return semDelete (ID);
     258   end Binary_Semaphore_Obtain;
     259
     260   -----------------------------
     261   -- Binary_Semaphore_Obtain --
     262   -----------------------------
     263
     264   function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int is
     265   begin
     266      return semTake (ID, WAIT_FOREVER);
     267   end Binary_Semaphore_Obtain;
     268
     269   ------------------------------
     270   -- Binary_Semaphore_Release --
     271   ------------------------------
     272
     273   function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int is
     274   begin
     275      return semGive (ID);
     276   end Binary_Semaphore_Release;
     277
     278   ----------------------------
     279   -- Binary_Semaphore_Flush --
     280   ----------------------------
     281
     282   function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int is
     283   begin
     284      return semFlush (ID);
     285   end Binary_Semaphore_Flush;
     286
     287
     288   ----------------------------
     289   -- Interrupt_Connect --
     290   ----------------------------
     291
     292   function Interrupt_Connect
     293     (Vector    : Interrupt_Vector;
     294      Handler   : Interrupt_Handler;
     295      Parameter : System.Address := System.Null_Address) return int is
     296   begin
     297     return intConnect (Vector, Handler, Parameter);
     298   end Interrupt_Connect;
     299
     300   ----------------------------
     301   -- Interrupt_Vector_Get --
     302   ----------------------------
     303
     304   function Interrupt_Vector_Get
     305     (Vector : Interrupt_Vector) return Interrupt_Handler is
     306   begin
     307     return intVecGet (Vector);
     308   end Interrupt_Get;
     309
     310   ----------------------------
     311   -- Interrupt_Vector_Set --
     312   ----------------------------
     313
     314   procedure Interrupt_Vector_Set
     315     (Vector  : Interrupt_Vector;
     316      Handler : Interrupt_Handler) is
     317   begin
     318      intVecSet (Interfaces.VxWorks.INUM_TO_IVEC (Vector), Handler);
     319   end Interrupt_Vector_Set;
     320
     321   ----------------------------r --
     322   -- Interrupt_Number_To_Vector --
     323   ----------------------------r --
     324
     325   function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector is
     326   begin
     327      return INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt));
     328   end Interrupt_Number_To_Vector;
     329
    242330end System.OS_Interface;
  • gcc/ada/s-osinte-vxworks.ads

    diff -urN gcc-4.3.2-orig/gcc/ada/s-osinte-vxworks.ads gcc-4.3.2/gcc/ada/s-osinte-vxworks.ads
    old new  
    393393   pragma Import (C, semFlush, "semFlush");
    394394   --  Release all threads blocked on the semaphore
    395395
     396   ------------------------------------------------------------
     397   --   Binary Semaphore Wrapper to Support Interrupt Tasks  --
     398   ------------------------------------------------------------
     399
     400   type Binary_Semaphore_Id is new SEM_ID;
     401
     402   function Binary_Semaphore_Create return Binary_Semaphore_Id;
     403
     404   function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int;
     405
     406   function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int;
     407
     408   function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int;
     409
     410   function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int;
     411
     412   ------------------------------------------------------------
     413   -- Hardware Interrupt Wrappers to Support Interrupt Tasks --
     414   ------------------------------------------------------------
     415
     416   type Interrupt_Handler is access procedure (parameter : System.Address);
     417   type Interrupt_Vector is new System.Address;
     418
     419   function Interrupt_Connect
     420     (Vector    : Interrupt_Vector;
     421      Handler   : Interrupt_Handler;
     422      Parameter : System.Address := System.Null_Address) return int;
     423   --  Use this to set up an user handler. The routine installs a
     424   --  a user handler which is invoked after RTEMS has saved enough
     425   --  context for a high-level language routine to be safely invoked.
     426
     427   function Interrupt_Vector_Get
     428     (Vector : Interrupt_Vector) return Interrupt_Handler;
     429   --  Use this to get the existing handler for later restoral.
     430
     431   procedure Interrupt_Vector_Set
     432     (Vector  : Interrupt_Vector;
     433      Handler : Interrupt_Handler);
     434   --  Use this to restore a handler obtained using Interrupt_Vector_Get.
     435
     436   function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector;
     437   --  Convert a logical interrupt number to the hardware interrupt vector
     438   --  number used to connect the interrupt.
     439
    396440private
    397441   type sigset_t is new long;
    398442
  • gcc/ada/s-stchop-rtems.adb

    diff -urN gcc-4.3.2-orig/gcc/ada/s-stchop-rtems.adb gcc-4.3.2/gcc/ada/s-stchop-rtems.adb
    old new  
     1------------------------------------------------------------------------------
     2--                                                                          --
     3--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
     4--                                                                          --
     5--     S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S      --
     6--                                                                          --
     7--                                  B o d y                                 --
     8--                                                                          --
     9--          Copyright (C) 1999-2008, Free Software Foundation, Inc.         --
     10--                                                                          --
     11-- GNARL is free software; you can  redistribute it  and/or modify it under --
     12-- terms of the  GNU General Public License as published  by the Free Soft- --
     13-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
     14-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
     15-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
     16-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
     17-- for  more details.  You should have  received  a copy of the GNU General --
     18-- Public License  distributed with GNARL; see file COPYING.  If not, write --
     19-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
     20-- Boston, MA 02110-1301, USA.                                              --
     21--                                                                          --
     22-- As a special exception,  if other files  instantiate  generics from this --
     23-- unit, or you link  this unit with other files  to produce an executable, --
     24-- this  unit  does not  by itself cause  the resulting  executable  to  be --
     25-- covered  by the  GNU  General  Public  License.  This exception does not --
     26-- however invalidate  any other reasons why  the executable file  might be --
     27-- covered by the  GNU Public License.                                      --
     28--                                                                          --
     29-- GNARL was developed by the GNARL team at Florida State University.       --
     30-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
     31--                                                                          --
     32------------------------------------------------------------------------------
     33
     34--  This is the RTEMS version of this package.
     35--  This file should be kept synchronized with the general implementation
     36--  provided by s-stchop.adb.
     37
     38pragma Restrictions (No_Elaboration_Code);
     39--  We want to guarantee the absence of elaboration code because the
     40--  binder does not handle references to this package.
     41
     42with Ada.Exceptions;
     43
     44with Interfaces.C; use Interfaces.C;
     45
     46package body System.Stack_Checking.Operations is
     47
     48   ----------------------------
     49   -- Invalidate_Stack_Cache --
     50   ----------------------------
     51
     52   procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is
     53      pragma Warnings (Off, Any_Stack);
     54   begin
     55      Cache := Null_Stack;
     56   end Invalidate_Stack_Cache;
     57
     58   -----------------------------
     59   -- Notify_Stack_Attributes --
     60   -----------------------------
     61
     62   procedure Notify_Stack_Attributes
     63     (Initial_SP : System.Address;
     64      Size       : System.Storage_Elements.Storage_Offset)
     65   is
     66
     67      --  RTEMS keeps all the information we need.
     68
     69      pragma Unreferenced (Size);
     70      pragma Unreferenced (Initial_SP);
     71
     72   begin
     73      null;
     74   end Notify_Stack_Attributes;
     75
     76   -----------------
     77   -- Stack_Check --
     78   -----------------
     79
     80   function Stack_Check
     81     (Stack_Address : System.Address) return Stack_Access
     82   is
     83      pragma Unreferenced (Stack_Address);
     84
     85      --  RTEMS has a routine to check this.  So use it.
     86      function rtems_stack_checker_is_blown return Interfaces.C.int;
     87      pragma Import (C,
     88         rtems_stack_checker_is_blown, "rtems_stack_checker_is_blown");
     89
     90   begin
     91      --  RTEMS has a routine to check this.  So use it.
     92
     93      if rtems_stack_checker_is_blown /= 0 then
     94         Ada.Exceptions.Raise_Exception
     95           (E       => Storage_Error'Identity,
     96            Message => "stack overflow detected");
     97      end if;
     98
     99      return null;
     100
     101   end Stack_Check;
     102
     103   ------------------------
     104   -- Update_Stack_Cache --
     105   ------------------------
     106
     107   procedure Update_Stack_Cache (Stack : Stack_Access) is
     108   begin
     109      if not Multi_Processor then
     110         Cache := Stack;
     111      end if;
     112   end Update_Stack_Cache;
     113
     114end System.Stack_Checking.Operations;
Note: See TracBrowser for help on using the repository browser.