gcc/ada/5amastop.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                     SYSTEM.MACHINE_STATE_OPERATIONS                      --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                         (Version for Alpha/Dec Unix)                     --
   9 --                                                                          --
  10 --                                                                          --
  11 --           Copyright (C) 1999-2001 Ada Core Technologies, 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 --  This version of System.Machine_State_Operations is for use on
  37 --  Alpha systems running DEC Unix.
  38
  39 with System.Memory;
  40
  41 package body System.Machine_State_Operations is
  42
  43    use System.Exceptions;
  44
  45    pragma Linker_Options ("-lexc");
  46    --  Needed for definitions of exc_capture_context and exc_virtual_unwind
  47
  48    ----------------------------
  49    -- Allocate_Machine_State --
  50    ----------------------------
  51
  52    function Allocate_Machine_State return Machine_State is
  53       use System.Storage_Elements;
  54
  55       function c_machine_state_length return Storage_Offset;
  56       pragma Import (C, c_machine_state_length, "__gnat_machine_state_length");
  57
  58    begin
  59       return Machine_State
  60         (Memory.Alloc (Memory.size_t (c_machine_state_length)));
  61    end Allocate_Machine_State;
  62
  63    -------------------
  64    -- Enter_Handler --
  65    -------------------
  66
  67    procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is
  68       procedure c_enter_handler (M : Machine_State; Handler : Handler_Loc);
  69       pragma Import (C, c_enter_handler, "__gnat_enter_handler");
  70
  71    begin
  72       c_enter_handler (M, Handler);
  73    end Enter_Handler;
  74
  75    ----------------
  76    -- Fetch_Code --
  77    ----------------
  78
  79    function Fetch_Code (Loc : Code_Loc) return Code_Loc is
  80    begin
  81       return Loc;
  82    end Fetch_Code;
  83
  84    ------------------------
  85    -- Free_Machine_State --
  86    ------------------------
  87
  88    procedure Free_Machine_State (M : in out Machine_State) is
  89    begin
  90       Memory.Free (Address (M));
  91       M := Machine_State (Null_Address);
  92    end Free_Machine_State;
  93
  94    ------------------
  95    -- Get_Code_Loc --
  96    ------------------
  97
  98    function Get_Code_Loc (M : Machine_State) return Code_Loc is
  99       Asm_Call_Size : constant := 4;
 100
 101       function c_get_code_loc (M : Machine_State) return Code_Loc;
 102       pragma Import (C, c_get_code_loc, "__gnat_get_code_loc");
 103
 104       --  Code_Loc returned by c_get_code_loc is the return point but here we
 105       --  want Get_Code_Loc to return the call point. Under DEC Unix a call
 106       --  asm instruction takes 4 bytes. So we must remove this value from
 107       --  c_get_code_loc to have the call point.
 108
 109    begin
 110       return c_get_code_loc (M) - Asm_Call_Size;
 111    end Get_Code_Loc;
 112
 113    --------------------------
 114    -- Machine_State_Length --
 115    --------------------------
 116
 117    function Machine_State_Length
 118      return System.Storage_Elements.Storage_Offset
 119    is
 120       use System.Storage_Elements;
 121
 122       function c_machine_state_length return Storage_Offset;
 123       pragma Import (C, c_machine_state_length, "__gnat_machine_state_length");
 124
 125    begin
 126       return c_machine_state_length;
 127    end Machine_State_Length;
 128
 129    ---------------
 130    -- Pop_Frame --
 131    ---------------
 132
 133    procedure Pop_Frame
 134      (M    : Machine_State;
 135       Info : Subprogram_Info_Type)
 136    is
 137       procedure exc_virtual_unwind
 138         (Fcn  : System.Address;
 139          M    : Machine_State);
 140       pragma Import (C, exc_virtual_unwind, "exc_virtual_unwind");
 141
 142    begin
 143       exc_virtual_unwind (System.Null_Address, M);
 144    end Pop_Frame;
 145
 146    -----------------------
 147    -- Set_Machine_State --
 148    -----------------------
 149
 150    procedure Set_Machine_State (M : Machine_State) is
 151       procedure c_capture_context (M : Machine_State);
 152       pragma Import (C, c_capture_context, "exc_capture_context");
 153
 154    begin
 155       c_capture_context (M);
 156       Pop_Frame (M, System.Null_Address);
 157    end Set_Machine_State;
 158
 159    ------------------------------
 160    -- Set_Signal_Machine_State --
 161    ------------------------------
 162
 163    procedure Set_Signal_Machine_State
 164      (M       : Machine_State;
 165       Context : System.Address) is
 166    begin
 167       null;
 168    end Set_Signal_Machine_State;
 169
 170 end System.Machine_State_Operations;