development/compilers/freepascal/rtl/win32/signals.pp

   1 unit signals;
   2
   3 interface
   4
   5   { Signals }
   6   const
   7     SIGABRT   = 288;
   8     SIGFPE    = 289;
   9     SIGILL    = 290;
  10     SIGSEGV   = 291;
  11     SIGTERM   = 292;
  12     SIGALRM   = 293;
  13     SIGHUP    = 294;
  14     SIGINT    = 295;
  15     SIGKILL   = 296;
  16     SIGPIPE   = 297;
  17     SIGQUIT   = 298;
  18     SIGUSR1   = 299;
  19     SIGUSR2   = 300;
  20     SIGNOFP   = 301;
  21     SIGTRAP   = 302;
  22     SIGTIMR   = 303;    { Internal for setitimer (SIGALRM, SIGPROF) }
  23     SIGPROF   = 304;
  24     SIGMAX    = 320;
  25
  26     SIG_BLOCK   = 1;
  27     SIG_SETMASK = 2;
  28     SIG_UNBLOCK = 3;
  29
  30   function SIG_DFL( x: longint) : longint;
  31
  32   function SIG_ERR( x: longint) : longint;
  33
  34   function SIG_IGN( x: longint) : longint;
  35
  36   type
  37
  38     SignalHandler  = function (v : longint) : longint;
  39
  40     PSignalHandler = ^SignalHandler; { to be compatible with linux.pp }
  41
  42   function signal(sig : longint;func : SignalHandler) : SignalHandler;
  43
  44   const
  45
  46      EXCEPTION_MAXIMUM_PARAMETERS = 15;
  47
  48   type
  49
  50      FLOATING_SAVE_AREA = record
  51           ControlWord : DWORD;
  52           StatusWord : DWORD;
  53           TagWord : DWORD;
  54           ErrorOffset : DWORD;
  55           ErrorSelector : DWORD;
  56           DataOffset : DWORD;
  57           DataSelector : DWORD;
  58           RegisterArea : array[0..79] of BYTE;
  59           Cr0NpxState : DWORD;
  60        end;
  61      _FLOATING_SAVE_AREA = FLOATING_SAVE_AREA;
  62      TFLOATINGSAVEAREA = FLOATING_SAVE_AREA;
  63      PFLOATINGSAVEAREA = ^FLOATING_SAVE_AREA;
  64
  65      CONTEXT = record
  66           ContextFlags : DWORD;
  67           Dr0 : DWORD;
  68           Dr1 : DWORD;
  69           Dr2 : DWORD;
  70           Dr3 : DWORD;
  71           Dr6 : DWORD;
  72           Dr7 : DWORD;
  73           FloatSave : FLOATING_SAVE_AREA;
  74           SegGs : DWORD;
  75           SegFs : DWORD;
  76           SegEs : DWORD;
  77           SegDs : DWORD;
  78           Edi : DWORD;
  79           Esi : DWORD;
  80           Ebx : DWORD;
  81           Edx : DWORD;
  82           Ecx : DWORD;
  83           Eax : DWORD;
  84           Ebp : DWORD;
  85           Eip : DWORD;
  86           SegCs : DWORD;
  87           EFlags : DWORD;
  88           Esp : DWORD;
  89           SegSs : DWORD;
  90        end;
  91      LPCONTEXT = ^CONTEXT;
  92      _CONTEXT = CONTEXT;
  93      TCONTEXT = CONTEXT;
  94      PCONTEXT = ^CONTEXT;
  95
  96
  97   type
  98      pexception_record = ^exception_record;
  99      EXCEPTION_RECORD  = record
 100        ExceptionCode   : longint;
 101        ExceptionFlags  : longint;
 102        ExceptionRecord : pexception_record;
 103        ExceptionAddress : pointer;
 104        NumberParameters : longint;
 105        ExceptionInformation : array[0..EXCEPTION_MAXIMUM_PARAMETERS-1] of pointer;
 106      end;
 107
 108      PEXCEPTION_POINTERS = ^EXCEPTION_POINTERS;
 109      EXCEPTION_POINTERS = record
 110        ExceptionRecord   : PEXCEPTION_RECORD ;
 111        ContextRecord     : PCONTEXT ;
 112      end;
 113
 114
 115
 116 implementation
 117
 118
 119 const
 120      EXCEPTION_ACCESS_VIOLATION = $c0000005;
 121      EXCEPTION_BREAKPOINT = $80000003;
 122      EXCEPTION_DATATYPE_MISALIGNMENT = $80000002;
 123      EXCEPTION_SINGLE_STEP = $80000004;
 124      EXCEPTION_ARRAY_BOUNDS_EXCEEDED = $c000008c;
 125      EXCEPTION_FLT_DENORMAL_OPERAND = $c000008d;
 126      EXCEPTION_FLT_DIVIDE_BY_ZERO = $c000008e;
 127      EXCEPTION_FLT_INEXACT_RESULT = $c000008f;
 128      EXCEPTION_FLT_INVALID_OPERATION = $c0000090;
 129      EXCEPTION_FLT_OVERFLOW = $c0000091;
 130      EXCEPTION_FLT_STACK_CHECK = $c0000092;
 131      EXCEPTION_FLT_UNDERFLOW = $c0000093;
 132      EXCEPTION_INT_DIVIDE_BY_ZERO = $c0000094;
 133      EXCEPTION_INT_OVERFLOW = $c0000095;
 134      EXCEPTION_INVALID_HANDLE = $c0000008;
 135      EXCEPTION_PRIV_INSTRUCTION = $c0000096;
 136      EXCEPTION_NONCONTINUABLE_EXCEPTION = $c0000025;
 137      EXCEPTION_NONCONTINUABLE = $1;
 138      EXCEPTION_STACK_OVERFLOW = $c00000fd;
 139      EXCEPTION_INVALID_DISPOSITION = $c0000026;
 140      EXCEPTION_ILLEGAL_INSTRUCTION = $C000001D;
 141      EXCEPTION_IN_PAGE_ERROR = $C0000006;
 142
 143      EXCEPTION_EXECUTE_HANDLER = 1;
 144      EXCEPTION_CONTINUE_EXECUTION = -(1);
 145      EXCEPTION_CONTINUE_SEARCH = 0;
 146
 147   type
 148      { type of functions that should be used for exception handling }
 149      LPTOP_LEVEL_EXCEPTION_FILTER = function(excep :PEXCEPTION_POINTERS) : longint;stdcall;
 150
 151      function SetUnhandledExceptionFilter(lpTopLevelExceptionFilter : LPTOP_LEVEL_EXCEPTION_FILTER)
 152        : LPTOP_LEVEL_EXCEPTION_FILTER;
 153        external 'kernel32' name 'SetUnhandledExceptionFilter';
 154
 155 var
 156   signal_list : Array[SIGABRT..SIGMAX] of SignalHandler;
 157 var
 158   { value of the stack segment
 159     to check if the call stack can be written on exceptions }
 160   _SS : longint;
 161
 162 const
 163   fpucw : word = $1332;
 164
 165
 166
 167   function Signals_exception_handler(excep :PEXCEPTION_POINTERS) : longint;stdcall;
 168     var frame,res  : longint;
 169         function CallSignal(error,frame : longint;must_reset_fpu : boolean) : longint;
 170           begin
 171             CallSignal:=Exception_Continue_Search;
 172 {$ifdef i386}
 173             if must_reset_fpu then
 174               asm
 175                 fninit
 176                 fldcw   fpucw
 177               end;
 178 {$endif i386}
 179             if (error>=SIGABRT) and (error<=SIGMAX) and (signal_list[error]<>@SIG_DFL) then
 180               res:=signal_list[error](error);
 181             if res>=0 then
 182               CallSignal:=Exception_Continue_Execution;
 183           end;
 184
 185     begin
 186 {$ifdef i386}
 187        if excep^.ContextRecord^.SegSs=_SS then
 188          frame:=excep^.ContextRecord^.Ebp
 189        else
 190 {$endif i386}
 191          frame:=0;
 192        { default : unhandled !}
 193        res:=Exception_Continue_Search;
 194 {$ifdef SYSTEMEXCEPTIONDEBUG}
 195        if IsConsole then
 196          writeln(stderr,'Exception  ',
 197            hexstr(excep^.ExceptionRecord^.ExceptionCode,8));
 198 {$endif SYSTEMEXCEPTIONDEBUG}
 199        case excep^.ExceptionRecord^.ExceptionCode of
 200          EXCEPTION_ACCESS_VIOLATION :
 201            res:=CallSignal(SIGSEGV,frame,false);
 202          { EXCEPTION_BREAKPOINT = $80000003;
 203          EXCEPTION_DATATYPE_MISALIGNMENT = $80000002;
 204          EXCEPTION_SINGLE_STEP = $80000004; }
 205          EXCEPTION_ARRAY_BOUNDS_EXCEEDED :
 206            res:=CallSignal(SIGSEGV,frame,false);
 207          EXCEPTION_FLT_DENORMAL_OPERAND :
 208            begin
 209              res:=CallSignal(SIGFPE,frame,true);
 210            end;
 211          EXCEPTION_FLT_DIVIDE_BY_ZERO :
 212            begin
 213              res:=CallSignal(SIGFPE,frame,true);
 214              {excep^.ContextRecord^.FloatSave.StatusWord:=excep^.ContextRecord^.FloatSave.StatusWord and $ffffff00;}
 215            end;
 216          {EXCEPTION_FLT_INEXACT_RESULT = $c000008f; }
 217          EXCEPTION_FLT_INVALID_OPERATION :
 218            begin
 219              res:=CallSignal(SIGFPE,frame,true);
 220            end;
 221          EXCEPTION_FLT_OVERFLOW :
 222            begin
 223              res:=CallSignal(SIGFPE,frame,true);
 224            end;
 225          EXCEPTION_FLT_STACK_CHECK :
 226            begin
 227              res:=CallSignal(SIGFPE,frame,true);
 228            end;
 229          EXCEPTION_FLT_UNDERFLOW :
 230            begin
 231              res:=CallSignal(SIGFPE,frame,true); { should be accepted as zero !! }
 232            end;
 233          EXCEPTION_INT_DIVIDE_BY_ZERO :
 234            res:=CallSignal(SIGFPE,frame,false);
 235          EXCEPTION_INT_OVERFLOW :
 236            res:=CallSignal(SIGFPE,frame,false);
 237          {EXCEPTION_INVALID_HANDLE = $c0000008;
 238          EXCEPTION_PRIV_INSTRUCTION = $c0000096;
 239          EXCEPTION_NONCONTINUABLE_EXCEPTION = $c0000025;
 240          EXCEPTION_NONCONTINUABLE = $1;}
 241          EXCEPTION_STACK_OVERFLOW :
 242            res:=CallSignal(SIGSEGV,frame,false);
 243          {EXCEPTION_INVALID_DISPOSITION = $c0000026;}
 244          EXCEPTION_ILLEGAL_INSTRUCTION,
 245          EXCEPTION_PRIV_INSTRUCTION,
 246          EXCEPTION_IN_PAGE_ERROR,
 247          EXCEPTION_SINGLE_STEP : res:=CallSignal(SIGSEGV,frame,false);
 248          end;
 249        Signals_exception_handler:=res;
 250     end;
 251
 252
 253   procedure install_exception_handler;
 254 {$ifdef SYSTEMEXCEPTIONDEBUG}
 255     var
 256       oldexceptaddr,newexceptaddr : longint;
 257 {$endif SYSTEMEXCEPTIONDEBUG}
 258     begin
 259 {$ifdef SYSTEMEXCEPTIONDEBUG}
 260       asm
 261         movl $0,%eax
 262         movl %fs:(%eax),%eax
 263         movl %eax,oldexceptaddr
 264       end;
 265 {$endif SYSTEMEXCEPTIONDEBUG}
 266       SetUnhandledExceptionFilter(@Signals_exception_handler);
 267 {$ifdef SYSTEMEXCEPTIONDEBUG}
 268       asm
 269         movl $0,%eax
 270         movl %fs:(%eax),%eax
 271         movl %eax,newexceptaddr
 272       end;
 273       if IsConsole then
 274         writeln(stderr,'Old exception  ',hexstr(oldexceptaddr,8),
 275           ' new exception  ',hexstr(newexceptaddr,8));
 276 {$endif SYSTEMEXCEPTIONDEBUG}
 277     end;
 278
 279   procedure remove_exception_handler;
 280     begin
 281       SetUnhandledExceptionFilter(nil);
 282     end;
 283
 284
 285 function SIG_ERR(x:longint):longint;
 286 begin
 287   SIG_ERR:=-1;
 288 end;
 289
 290
 291 function SIG_IGN(x:longint):longint;
 292 begin
 293   SIG_IGN:=-1;
 294 end;
 295
 296
 297 function SIG_DFL(x:longint):longint;
 298 begin
 299   SIG_DFL:=0;
 300 end;
 301
 302 function signal(sig : longint;func : SignalHandler) : SignalHandler;
 303 var
 304   temp : SignalHandler;
 305 begin
 306   if ((sig < SIGABRT) or (sig > SIGMAX) or (sig = SIGKILL)) then
 307    begin
 308      signal:=@SIG_ERR;
 309      runerror(201);
 310    end;
 311   temp := signal_list[sig];
 312   signal_list[sig] := func;
 313   signal:=temp;
 314 end;
 315
 316
 317 var
 318   i : longint;
 319 initialization
 320
 321 {$ifdef i386}
 322   asm
 323     xorl %eax,%eax
 324     movw %ss,%ax
 325     movl %eax,_SS
 326   end;
 327 {$endif i386}
 328
 329   for i:=SIGABRT to SIGMAX do
 330     signal_list[i]:=@SIG_DFL;
 331   install_exception_handler;
 332
 333 finalization
 334
 335   remove_exception_handler;
 336 end.