home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / gnat-3.05- / gnat-3 / gnat-3.05-i486-linux-elf-bin / rts / 2dcemasp.adb < prev    next >
Encoding:
Text File  |  1996-06-07  |  7.5 KB  |  179 lines

  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                 GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS               --
  4. --                                                                          --
  5. -- C O M P I L E R _ E X C E P T I O N S . M A C H I N E _ S P E C I F I C S--
  6. --                                                                          --
  7. --                                  B o d y                                 --
  8. --                                                                          --
  9. --                             $Revision: 1.1 $                             --
  10. --                                                                          --
  11. --   Copyright (C) 1991,1992,1993,1994,1995,1996 Florida State University   --
  12. --                                                                          --
  13. -- GNARL 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. GNARL 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 GNARL; 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. -- GNARL was developed by the GNARL team at Florida State University. It is --
  32. -- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
  33. -- State University (http://www.gnat.com).                                  --
  34. --                                                                          --
  35. ------------------------------------------------------------------------------
  36.  
  37. --  This is the DJGPP V2 version of this package.
  38.  
  39. --  This file performs the system-dependent translation between machine
  40. --  exceptions and the Ada exceptions, if any, that should be raised when
  41. --  they occur.  This version works for the i486 running linux.
  42.  
  43. --  ??? This should not be part of tasking, since it is needed whether tasking
  44. --      is used or not.  This file will eventually go away or be incorporated
  45. --      into the non-tasking runtime.
  46.  
  47. with Interfaces.C; use Interfaces.C;
  48.  
  49. with Interfaces.C.POSIX_RTE;
  50.  
  51. package body System.Compiler_Exceptions.Machine_Specifics is
  52.  
  53.    package RTE renames Interfaces.C.POSIX_RTE;
  54.  
  55.    ------------------------
  56.    -- Identify_Exception --
  57.    ------------------------
  58.  
  59.    --  This function identifies the Ada exception to be raised using
  60.    --  the information when the system received a synchronous signal.
  61.    --  Since this function is machine and OS dependent, different code
  62.    --  has to be provided for different target.
  63.  
  64.    --  Following code is intended for i486.
  65.  
  66.    function Identify_Exception
  67.      (Which              : System.Task_Primitives.Machine_Exceptions;
  68.       Info               : System.Task_Primitives.Error_Information;
  69.       Modified_Registers : Pre_Call_State) return Ada.Exceptions.Exception_Id
  70.    is
  71.  
  72.       type sigcontext is record
  73.          gs            : unsigned_short;
  74.          fs            : unsigned_short;
  75.          es            : unsigned_short;
  76.          ds            : unsigned_short;
  77.          edi           : unsigned_long;
  78.          esi           : unsigned_long;
  79.          ebp           : unsigned_long;
  80.          esp           : unsigned_long;
  81.          ebx           : unsigned_long;
  82.          edx           : unsigned_long;
  83.          ecx           : unsigned_long;
  84.          eax           : unsigned_long;
  85.          trapno        : unsigned_long;
  86.          err           : unsigned_long;
  87.          eip           : unsigned_long;
  88.          cs            : unsigned_short;
  89.          eflags        : unsigned_long;
  90.          esp_at_signal : unsigned_long;
  91.          ss            : unsigned_short;
  92.          i387          : unsigned_long;
  93.          oldmask       : unsigned_long;
  94.          cr2           : unsigned_long;
  95.       end record;
  96.  
  97.       type sigcontext_ptr is access sigcontext;
  98.  
  99.       --  The above operations will be available as predefined operations on
  100.       --  the modula Address type in GNARL, since this package is a child of
  101.       --  System.
  102.  
  103.       FPE_INTOVF_TRAP   : constant int := 16#1#;  -- Int overflow
  104.       FPE_STARTSIG_TRAP : constant int := 16#2#;  -- process using fp
  105.       FPE_INTDIV_TRAP   : constant int := 16#14#; -- Int divide by zero
  106.       FPE_FLTINEX_TRAP  : constant int := 16#c4#; -- floating inexact result
  107.       FPE_FLTDIV_TRAP   : constant int := 16#c8#; -- floating divide by zero
  108.       FPE_FLTUND_TRAP   : constant int := 16#cc#; -- floating underflow
  109.       FPE_FLTOPERR_TRAP : constant int := 16#d0#; -- floating operand error
  110.       FPE_FLTOVF_TRAP   : constant int := 16#d4#; -- floating overflow
  111.  
  112.       --  Following is SIGILL generated by trap 5 instruction
  113.  
  114.       ILL_CHECK_TRAP    : constant int := 16#80# + 16#05#;
  115.  
  116.       function Pre_Call_To_Context is new
  117.         Unchecked_Conversion (Pre_Call_State, sigcontext_ptr);
  118.  
  119.  
  120.       Current_Exception : Ada.Exceptions.Exception_Id;
  121.  
  122.       context : sigcontext_ptr :=
  123.                   Pre_Call_To_Context (Modified_Registers);
  124.  
  125.       sig     : RTE.Signal := RTE.Signal (Which);
  126.  
  127.    begin
  128.  
  129.       --  As long as we are using a longjmp to return control to the
  130.       --  exception handler on the runtime stack, we are safe. The original
  131.       --  signal mask (the one we had before coming into this signal catching
  132.       --  function) will be restored by the longjmp. Therefore, raising
  133.       --  an exception in this handler should be a safe operation.
  134.  
  135.       case sig is
  136.  
  137.          when RTE.SIGFPE =>
  138.  
  139.             Current_Exception := Constraint_Error_Id;
  140.  
  141.          when RTE.SIGILL =>
  142.  
  143.             case Info.si_code is
  144.  
  145.                when ILL_CHECK_TRAP =>
  146.                   Current_Exception := Constraint_Error_Id;
  147.  
  148.                when others =>
  149.  
  150.                   pragma Assert (false, "Unexpected SIGILL signal");
  151.                   null;
  152.             end case;
  153.  
  154.          when RTE.SIGSEGV =>
  155.  
  156.             Current_Exception := Storage_Error_Id;
  157.  
  158.          --  If the address that caused the error was in the first page, this
  159.          --  was caused by accessing a null pointer.
  160.  
  161. --            if context.sc_o0 >= 0 and context.sc_o0 < 16#2000# then
  162. --               Current_Exception := Constraint_Error_Id;
  163. --
  164. --            else
  165. --               Current_Exception := Storage_Error_Id;
  166. --            end if;
  167.  
  168.          when others =>
  169.  
  170.             pragma Assert (false, "Unexpected signal");
  171.             null;
  172.       end case;
  173.  
  174.       return Current_Exception;
  175.  
  176.    end Identify_Exception;
  177.  
  178. end System.Compiler_Exceptions.Machine_Specifics;
  179.