home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / i-cporte.adb < prev    next >
Text File  |  1996-09-28  |  9KB  |  281 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                 GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS               --
  4. --                                                                          --
  5. --                I N T E R F A C E S . C . P O S I X _ R T E               --
  6. --                                                                          --
  7. --                                  B o d y                                 --
  8. --                                                                          --
  9. --                             $Revision: 1.6 $                             --
  10. --                                                                          --
  11. --       Copyright (c) 1991,1992,1993,1994, FSU, All Rights Reserved        --
  12. --                                                                          --
  13. -- GNARL is free software; you can redistribute it  and/or modify it  under --
  14. -- terms  of  the  GNU  Library General Public License  as published by the --
  15. -- Free Software  Foundation;  either version 2, or (at  your  option)  any --
  16. -- later  version.  GNARL is distributed  in the hope that  it will be use- --
  17. -- ful, but but WITHOUT ANY WARRANTY;  without even the implied warranty of --
  18. -- MERCHANTABILITY  or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Gen- --
  19. -- eral Library Public License  for more details.  You should have received --
  20. -- a  copy of the GNU Library General Public License along with GNARL;  see --
  21. -- file COPYING.LIB.  If not,  write to the  Free Software Foundation,  675 --
  22. -- Mass Ave, Cambridge, MA 02139, USA.                                      --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with Interfaces.C.POSIX_Error; use Interfaces.C.Posix_Error;
  27. --  Used for, Return_Code
  28.  
  29. with Unchecked_Conversion;
  30.  
  31. package body Interfaces.C.POSIX_RTE is
  32.  
  33.    function Address_to_Pointer is new
  34.      Unchecked_Conversion (System.Address, sigaction_ptr);
  35.  
  36.    function Address_to_Pointer is new
  37.      Unchecked_Conversion (System.Address, sigset_t_ptr);
  38.  
  39.    function Address_to_Pointer is new
  40.      Unchecked_Conversion (System.Address, jmp_buf_ptr);
  41.  
  42.    function Address_to_Pointer is new
  43.      Unchecked_Conversion (System.Address, sigjmp_buf_ptr);
  44.  
  45.    --  The following are P1003.5 interfaces.  I am not sure that this is a
  46.    --  good idea, but these can't be exactly the same as the C functions
  47.    --  in any case.
  48.  
  49.    procedure sigaddset
  50.      (set : access Signal_Set;
  51.       sig : in Signal;
  52.       Result : out POSIX_Error.Return_Code)
  53.  
  54.    is
  55.       function sigaddset_base
  56.         (set : access Signal_Set;
  57.          sig : Signal)
  58.         return Return_Code;
  59.       pragma Import (C, sigaddset_base, "sigaddset");
  60.  
  61.    begin
  62.       Result := sigaddset_base (set, sig);
  63.    end sigaddset;
  64.  
  65.    procedure sigdelset
  66.      (set : access Signal_Set;
  67.       sig : in Signal;
  68.       Result : out POSIX_Error.Return_Code)
  69.    is
  70.       function sigdelset_base
  71.         (set : access Signal_Set;
  72.          sig : Signal)
  73.         return Return_Code;
  74.       pragma Import (C, sigdelset_base, "sigdelset");
  75.  
  76.    begin
  77.       Result := sigdelset_base (set, sig);
  78.    end sigdelset;
  79.  
  80.    procedure sigfillset
  81.      (set : access Signal_Set;
  82.       Result : out POSIX_Error.Return_Code)
  83.    is
  84.       function sigfillset_base
  85.         (set : access Signal_Set)
  86.         return Return_Code;
  87.       pragma Import (C, sigfillset_base, "sigfillset");
  88.  
  89.    begin
  90.       Result := sigfillset_base (set);
  91.    end sigfillset;
  92.  
  93.    procedure sigemptyset
  94.      (set : access Signal_Set;
  95.       Result : out POSIX_Error.Return_Code)
  96.    is
  97.       function sigemptyset_base
  98.         (set : access Signal_Set)
  99.         return Return_Code;
  100.       pragma Import (C, sigemptyset_base, "sigemptyset");
  101.  
  102.    begin
  103.       Result := sigemptyset_base (set);
  104.    end sigemptyset;
  105.  
  106.    ---------------
  107.    -- sigaction --
  108.    ---------------
  109.  
  110.    procedure sigaction
  111.      (sig    : Signal;
  112.       act    : access struct_sigaction;
  113.       oact   : access struct_sigaction;
  114.       Result : out POSIX_Error.Return_Code)
  115.    is
  116.       function sigaction_base
  117.         (sig  : Signal;
  118.          act  : access struct_sigaction;
  119.          oact : access struct_sigaction) return POSIX_Error.Return_Code;
  120.       pragma Import (C, sigaction_base, "sigaction");
  121.  
  122.    begin
  123.       Result := sigaction_base (sig, act, oact);
  124.    end sigaction;
  125.  
  126.    ---------------
  127.    -- sigaction --
  128.    ---------------
  129.  
  130.    procedure sigaction
  131.      (sig    : Signal;
  132.       oact   : access struct_sigaction;
  133.       Result : out Return_Code) is
  134.  
  135.       function sigaction_base
  136.         (sig  : Signal;
  137.          act  : sigaction_ptr;
  138.          oact : access struct_sigaction) return Return_Code;
  139.       pragma Import (C, sigaction_base, "sigaction");
  140.  
  141.    begin
  142.       Result := sigaction_base (sig, null, oact);
  143.    end sigaction;
  144.  
  145.    -----------------
  146.    -- sigprocmask --
  147.    -----------------
  148.  
  149.    --  Install new signal mask and obtain old one
  150.  
  151.    procedure sigprocmask
  152.      (how    : int;
  153.       set    : access Signal_Set;
  154.       oset   : access Signal_Set;
  155.       Result : out POSIX_Error.Return_Code)
  156.    is
  157.       function sigprocmask_base
  158.         (how  : int;
  159.          set  : access Signal_Set;
  160.          oset : access Signal_Set)
  161.          return POSIX_Error.Return_Code;
  162.       pragma Import (C, sigprocmask_base, "sigprocmask");
  163.  
  164.    begin
  165.       Result := sigprocmask_base (how, set, oset);
  166.    end sigprocmask;
  167.  
  168.    ----------------
  169.    -- sigsuspend --
  170.    ----------------
  171.  
  172.    --  Suspend waiting for signals in mask and resume after
  173.    --  executing handler or take default action
  174.  
  175.    procedure sigsuspend
  176.      (mask : access Signal_Set;
  177.       Result : out POSIX_Error.Return_Code) is
  178.  
  179.       function sigsuspend_base
  180.         (mask : access Signal_Set)
  181.          return POSIX_Error.Return_Code;
  182.       pragma Import (C, sigsuspend_base, "sigsuspend");
  183.  
  184.    begin
  185.       Result := sigsuspend_base (mask);
  186.    end sigsuspend;
  187.  
  188.    ----------------
  189.    -- sigpending --
  190.    ----------------
  191.  
  192.    --  Get pending signals on thread and process
  193.  
  194.    procedure sigpending
  195.      (set    : access Signal_Set;
  196.       Result : out POSIX_Error.Return_Code)
  197.    is
  198.       function sigpending_base
  199.         (set  : access Signal_Set)
  200.          return POSIX_Error.Return_Code;
  201.       pragma Import (C, sigpending_base, "sigpending");
  202.  
  203.    begin
  204.       Result := sigpending_base (set);
  205.    end sigpending;
  206.  
  207.    -------------
  208.    -- longjmp --
  209.    -------------
  210.  
  211.    --  Execute a jump across procedures according to setjmp
  212.  
  213.    procedure longjmp (env : jmp_buf; val : int) is
  214.       procedure longjmp_base (env : jmp_buf_ptr; val : int);
  215.       pragma Import (C, longjmp_base, "longjmp");
  216.  
  217.    begin
  218.       longjmp_base (Address_to_Pointer (env'Address), val);
  219.    end longjmp;
  220.  
  221.    ----------------
  222.    -- siglongjmp --
  223.    ----------------
  224.  
  225.    --  Execute a jump across procedures according to sigsetjmp
  226.  
  227.    procedure siglongjmp (env : sigjmp_buf; val : int) is
  228.       procedure siglongjmp_base (env : sigjmp_buf_ptr; val : int);
  229.       pragma Import (C, siglongjmp_base, "siglongjmp");
  230.  
  231.    begin
  232.       siglongjmp_base (Address_to_Pointer (env'Address), val);
  233.    end siglongjmp;
  234.  
  235.    ------------
  236.    -- setjmp --
  237.    ------------
  238.  
  239.    --  Set up a jump across procedures and return here with longjmp
  240.  
  241.    procedure setjmp (env : jmp_buf; Result : out Return_Code) is
  242.       function setjmp_base (env : jmp_buf_ptr) return Return_Code;
  243.       pragma Import (C, setjmp_base, "setjmp");
  244.  
  245.    begin
  246.       Result := setjmp_base (Address_to_Pointer (env'Address));
  247.    end setjmp;
  248.  
  249.    ---------------
  250.    -- sigsetjmp --
  251.    ---------------
  252.  
  253.    --  Set up a jump across procedures and return here with siglongjmp
  254.  
  255.    procedure sigsetjmp
  256.      (env      : sigjmp_buf;
  257.       savemask : int;
  258.       Result   : out Return_Code)
  259.    is
  260.       function sigsetjmp_base
  261.         (env      : sigjmp_buf_ptr;
  262.          savemask : int)
  263.          return     Return_Code;
  264.       pragma Import (C, sigsetjmp_base, "sigsetjmp");
  265.  
  266.    begin
  267.       Result := sigsetjmp_base (Address_to_Pointer (env'Address), savemask);
  268.    end sigsetjmp;
  269.  
  270. begin
  271.    for i in OS_Specific_Sync_Signals'Range loop
  272.       OS_Specific_Sync_Signals (i) :=
  273.         Signal (System_Constants.OS_Specific_Sync_Sigs (i));
  274.    end loop;
  275.  
  276.    for i in OS_Specific_Async_Signals'Range loop
  277.       OS_Specific_Async_Signals (i) :=
  278.         Signal (System_Constants.OS_Specific_Async_Sigs (i));
  279.    end loop;
  280. end Interfaces.C.POSIX_RTE;
  281.