home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / adav313.zip / gnat-3_13p-os2-bin-20010916.zip / emx / gnatlib / s-soflin.adb < prev    next >
Text File  |  2000-07-19  |  10KB  |  353 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                    S Y S T E M . S O F T _ L I N K S                     --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.10 $
  10. --                                                                          --
  11. --          Copyright (C) 1992-2000 Free Software Foundation, Inc.          --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22. -- MA 02111-1307, USA.                                                      --
  23. --                                                                          --
  24. -- As a special exception,  if other files  instantiate  generics from this --
  25. -- unit, or you link  this unit with other files  to produce an executable, --
  26. -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27. -- covered  by the  GNU  General  Public  License.  This exception does not --
  28. -- however invalidate  any other reasons why  the executable file  might be --
  29. -- covered by the  GNU Public License.                                      --
  30. --                                                                          --
  31. -- GNAT was originally developed  by the GNAT team at  New York University. --
  32. -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33. --                                                                          --
  34. ------------------------------------------------------------------------------
  35.  
  36. pragma Polling (Off);
  37. --  We must turn polling off for this unit, because otherwise we get
  38. --  an infinite loop from the code within the Poll routine itself.
  39.  
  40. with System.Parameters;
  41. --  Used for Sec_Stack_Ratio
  42.  
  43. with System.Secondary_Stack;
  44.  
  45. package body System.Soft_Links is
  46.  
  47.    package SST renames System.Secondary_Stack;
  48.  
  49.    --  Allocate an exception stack for the main program to use.
  50.    --  We make sure that the stack has maximum alignment. Some systems require
  51.    --  this (e.g. Sun), and in any case it is a good idea for efficiency.
  52.  
  53.    NT_Exc_Stack : array (0 .. 8192) of aliased Character;
  54.    for NT_Exc_Stack'Alignment use Standard'Maximum_Alignment;
  55.  
  56.    NT_TSD : TSD;
  57.  
  58.    --------------------
  59.    -- Abort_Defer_NT --
  60.    --------------------
  61.  
  62.    procedure Abort_Defer_NT is
  63.    begin
  64.       null;
  65.    end Abort_Defer_NT;
  66.  
  67.    ----------------------
  68.    -- Abort_Handler_NT --
  69.    ----------------------
  70.  
  71.    procedure Abort_Handler_NT is
  72.    begin
  73.       null;
  74.    end Abort_Handler_NT;
  75.  
  76.    ----------------------
  77.    -- Abort_Undefer_NT --
  78.    ----------------------
  79.  
  80.    procedure Abort_Undefer_NT is
  81.    begin
  82.       null;
  83.    end Abort_Undefer_NT;
  84.  
  85.    -------------------------
  86.    -- Update_Exception_NT --
  87.    -------------------------
  88.  
  89.    procedure Update_Exception_NT
  90.      (X : EO := Ada.Exceptions.Current_Target_Exception)
  91.    is
  92.    begin
  93.       Ada.Exceptions.Save_Occurrence (NT_TSD.Current_Excep, X);
  94.    end Update_Exception_NT;
  95.  
  96.    ---------------------------
  97.    -- Check_Abort_Status_NT --
  98.    ---------------------------
  99.  
  100.    function Check_Abort_Status_NT return Integer is
  101.    begin
  102.       return Boolean'Pos (False);
  103.    end Check_Abort_Status_NT;
  104.  
  105.    ------------------------
  106.    -- Complete_Master_NT --
  107.    ------------------------
  108.  
  109.    procedure Complete_Master_NT is
  110.    begin
  111.       null;
  112.    end Complete_Master_NT;
  113.  
  114.    -----------------------
  115.    -- Current_Master_NT --
  116.    -----------------------
  117.  
  118.    function Current_Master_NT return Integer is
  119.    begin
  120.       return 0;
  121.    end Current_Master_NT;
  122.  
  123.    ---------------------
  124.    -- Enter_Master_NT --
  125.    ---------------------
  126.  
  127.    procedure Enter_Master_NT is
  128.    begin
  129.       null;
  130.    end Enter_Master_NT;
  131.  
  132.    ------------------
  133.    -- Task_Lock_NT --
  134.    ------------------
  135.  
  136.    procedure Task_Lock_NT is
  137.    begin
  138.       null;
  139.    end Task_Lock_NT;
  140.  
  141.    --------------------
  142.    -- Task_Unlock_NT --
  143.    --------------------
  144.  
  145.    procedure Task_Unlock_NT is
  146.    begin
  147.       null;
  148.    end Task_Unlock_NT;
  149.  
  150.    ---------------------------
  151.    -- Get_Jmpbuf_Address_NT --
  152.    ---------------------------
  153.  
  154.    function Get_Jmpbuf_Address_NT return  Address is
  155.    begin
  156.       return NT_TSD.Jmpbuf_Address;
  157.    end Get_Jmpbuf_Address_NT;
  158.  
  159.    ---------------------------
  160.    -- Set_Jmpbuf_Address_NT --
  161.    ---------------------------
  162.  
  163.    procedure Set_Jmpbuf_Address_NT (Addr : Address) is
  164.    begin
  165.       NT_TSD.Jmpbuf_Address := Addr;
  166.    end Set_Jmpbuf_Address_NT;
  167.  
  168.    ---------------------------
  169.    -- Get_Sec_Stack_Addr_NT --
  170.    ---------------------------
  171.  
  172.    function Get_Sec_Stack_Addr_NT return  Address is
  173.    begin
  174.       return NT_TSD.Sec_Stack_Addr;
  175.    end Get_Sec_Stack_Addr_NT;
  176.  
  177.    ---------------------------
  178.    -- Set_Sec_Stack_Addr_NT --
  179.    ---------------------------
  180.  
  181.    procedure Set_Sec_Stack_Addr_NT (Addr : Address) is
  182.    begin
  183.       NT_TSD.Sec_Stack_Addr := Addr;
  184.    end Set_Sec_Stack_Addr_NT;
  185.  
  186.    -------------------------------
  187.    -- Get_Machine_State_Addr_NT --
  188.    -------------------------------
  189.  
  190.    function Get_Machine_State_Addr_NT return  Address is
  191.    begin
  192.       return NT_TSD.Machine_State_Addr;
  193.    end Get_Machine_State_Addr_NT;
  194.  
  195.    -------------------------------
  196.    -- Set_Machine_State_Addr_NT --
  197.    -------------------------------
  198.  
  199.    procedure Set_Machine_State_Addr_NT (Addr : Address) is
  200.    begin
  201.       NT_TSD.Machine_State_Addr := Addr;
  202.    end Set_Machine_State_Addr_NT;
  203.  
  204.    ---------------------------
  205.    -- Get_Exc_Stack_Addr_NT --
  206.    ---------------------------
  207.  
  208.    function Get_Exc_Stack_Addr_NT return Address is
  209.    begin
  210.       return NT_TSD.Exc_Stack_Addr;
  211.    end Get_Exc_Stack_Addr_NT;
  212.  
  213.    ---------------------------
  214.    -- Set_Exc_Stack_Addr_NT --
  215.    ---------------------------
  216.  
  217.    procedure Set_Exc_Stack_Addr_NT (Self_ID : Address; Addr : Address) is
  218.    begin
  219.       NT_TSD.Exc_Stack_Addr := Addr;
  220.    end Set_Exc_Stack_Addr_NT;
  221.  
  222.    --------------------------
  223.    -- Get_Current_Excep_NT --
  224.    --------------------------
  225.  
  226.    function Get_Current_Excep_NT return EOA is
  227.    begin
  228.       return NT_TSD.Current_Excep'Access;
  229.    end Get_Current_Excep_NT;
  230.  
  231.    -----------------------
  232.    -- Get_Stack_Info_NT --
  233.    -----------------------
  234.  
  235.    function Get_Stack_Info_NT return Stack_Checking.Stack_Access is
  236.    begin
  237.       return NT_TSD.Pri_Stack_Info'Access;
  238.    end Get_Stack_Info_NT;
  239.  
  240.    ----------------
  241.    -- Create_TSD --
  242.    ----------------
  243.  
  244.    procedure Create_TSD (New_TSD : in out TSD) is
  245.       use type Parameters.Size_Type;
  246.  
  247.       SS_Ratio_Dynamic : constant Boolean :=
  248.                            Parameters.Sec_Stack_Ratio = Parameters.Dynamic;
  249.    begin
  250.  
  251.       if SS_Ratio_Dynamic then
  252.          SST.SS_Init
  253.            (New_TSD.Sec_Stack_Addr, SST.Default_Secondary_Stack_Size);
  254.       end if;
  255.  
  256.       New_TSD.Machine_State_Addr := Ada.Exceptions.Allocate_Machine_State;
  257.    end Create_TSD;
  258.  
  259.    -----------------
  260.    -- Destroy_TSD --
  261.    -----------------
  262.  
  263.    procedure Destroy_TSD (Old_TSD : in out TSD) is
  264.    begin
  265.       SST.SS_Free (Old_TSD.Sec_Stack_Addr);
  266.       Ada.Exceptions.Deallocate_Machine_State (Old_TSD.Machine_State_Addr);
  267.    end Destroy_TSD;
  268.  
  269.    ------------------------
  270.    -- Get_GNAT_Exception --
  271.    ------------------------
  272.  
  273.    function Get_GNAT_Exception return Ada.Exceptions.Exception_Id is
  274.    begin
  275.       return Ada.Exceptions.Exception_Identity (Get_Current_Excep.all.all);
  276.    end Get_GNAT_Exception;
  277.  
  278.    -----------------------------
  279.    -- Get_Jmpbuf_Address_Soft --
  280.    -----------------------------
  281.  
  282.    function Get_Jmpbuf_Address_Soft return  Address is
  283.    begin
  284.       return Get_Jmpbuf_Address.all;
  285.    end Get_Jmpbuf_Address_Soft;
  286.  
  287.    -----------------------------
  288.    -- Set_Jmpbuf_Address_Soft --
  289.    -----------------------------
  290.  
  291.    procedure Set_Jmpbuf_Address_Soft (Addr : Address) is
  292.    begin
  293.       Set_Jmpbuf_Address (Addr);
  294.    end Set_Jmpbuf_Address_Soft;
  295.  
  296.    -----------------------------
  297.    -- Get_Sec_Stack_Addr_Soft --
  298.    -----------------------------
  299.  
  300.    function Get_Sec_Stack_Addr_Soft return  Address is
  301.    begin
  302.       return Get_Sec_Stack_Addr.all;
  303.    end Get_Sec_Stack_Addr_Soft;
  304.  
  305.    -----------------------------
  306.    -- Set_Sec_Stack_Addr_Soft --
  307.    -----------------------------
  308.  
  309.    procedure Set_Sec_Stack_Addr_Soft (Addr : Address) is
  310.    begin
  311.       Set_Sec_Stack_Addr (Addr);
  312.    end Set_Sec_Stack_Addr_Soft;
  313.  
  314.    -----------------------------
  315.    -- Get_Exc_Stack_Addr_Soft --
  316.    -----------------------------
  317.  
  318.    function Get_Exc_Stack_Addr_Soft return  Address is
  319.    begin
  320.       return Get_Exc_Stack_Addr.all;
  321.    end Get_Exc_Stack_Addr_Soft;
  322.  
  323.    -----------------------------
  324.    -- Set_Exc_Stack_Addr_Soft --
  325.    -----------------------------
  326.  
  327.    procedure Set_Exc_Stack_Addr_Soft (Self_ID : Address; Addr : Address) is
  328.    begin
  329.       Set_Exc_Stack_Addr (Self_ID, Addr);
  330.    end Set_Exc_Stack_Addr_Soft;
  331.  
  332.    ---------------------------------
  333.    -- Get_Machine_State_Addr_Soft --
  334.    ---------------------------------
  335.  
  336.    function Get_Machine_State_Addr_Soft return  Address is
  337.    begin
  338.       return Get_Machine_State_Addr.all;
  339.    end Get_Machine_State_Addr_Soft;
  340.  
  341.    ---------------------------------
  342.    -- Set_Machine_State_Addr_Soft --
  343.    ---------------------------------
  344.  
  345.    procedure Set_Machine_State_Addr_Soft (Addr : Address) is
  346.    begin
  347.       Set_Machine_State_Addr (Addr);
  348.    end Set_Machine_State_Addr_Soft;
  349.  
  350. begin
  351.    NT_TSD.Exc_Stack_Addr := NT_Exc_Stack (8192)'Address;
  352. end System.Soft_Links;
  353.