freepascal.compiler/rtl/go32v2/dpmiexcp.pp

{
    $Id$
    This file is part of the Free Pascal run time library.
    Copyright (c) 1999-2000 by Pierre Muller

    DPMI Exception routines for Go32V2

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}

{$GOTO ON}

Unit DPMIExcp;

{ If linking to C code we must avoid loading of the dpmiexcp.o
  in libc.a from the equivalent C code
  => all global functions from dpmiexcp.c must be aliased PM

  Problem this is only valid for DJGPP v2.01 }

interface

uses
  go32;

{ No stack checking ! }
{$S-}


{ Error Messages }
function do_faulting_finish_message : integer;

{ SetJmp/LongJmp }
type
  { must also contain exception_state !! }
  pdpmi_jmp_buf = ^dpmi_jmp_buf;
  dpmi_jmp_buf = packed record
      eax,ebx,ecx,edx,esi,edi,ebp,esp,eip,flags : longint;
      cs,ds,es,fs,gs,ss : word;
      sigmask : longint;        {  for POSIX signals only  }
      signum : longint;         {  for expansion ie 386 exception number }
      exception_ptr : pdpmi_jmp_buf;  { pointer to previous exception if exists }
  end;
function dpmi_setjmp(var rec : dpmi_jmp_buf) : longint;
procedure dpmi_longjmp(var rec : dpmi_jmp_buf;return_value : longint);

{ Signals }
const
  SIGABRT   = 288;
  SIGFPE    = 289;
  SIGILL    = 290;
  SIGSEGV   = 291;
  SIGTERM   = 292;
  SIGALRM   = 293;
  SIGHUP    = 294;
  SIGINT    = 295;
  SIGKILL   = 296;
  SIGPIPE   = 297;
  SIGQUIT   = 298;
  SIGUSR1   = 299;
  SIGUSR2   = 300;
  SIGNOFP   = 301;
  SIGTRAP   = 302;
  SIGTIMR   = 303;    { Internal for setitimer (SIGALRM, SIGPROF) }
  SIGPROF   = 304;
  SIGMAX    = 320;

  SIG_BLOCK   = 1;
  SIG_SETMASK = 2;
  SIG_UNBLOCK = 3;

function SIG_DFL( x: longint) : longint;
function SIG_ERR( x: longint) : longint;
function SIG_IGN( x: longint) : longint;

type
  SignalHandler  = function (v : longint) : longint;
  PSignalHandler = ^SignalHandler; { to be compatible with linux.pp }

function signal(sig : longint;func : SignalHandler) : SignalHandler;
function _raise(sig : longint) : longint;

{ Exceptions }
type
  pexception_state = ^texception_state;
  texception_state = record
    __eax, __ebx, __ecx, __edx, __esi : longint;
    __edi, __ebp, __esp, __eip, __eflags : longint;
    __cs, __ds, __es, __fs, __gs, __ss : word;
    __sigmask : longint;        {  for POSIX signals only  }
    __signum : longint;         {  for expansion  }
    __exception_ptr : pexception_state;  {  pointer to previous exception  }
    __fpu_state : array [0..108-1] of byte; {  for future use  }
  end;

procedure djgpp_exception_toggle;
procedure djgpp_exception_setup;
function  djgpp_exception_state : pexception_state;
function  djgpp_set_ctrl_c(enable : boolean) : boolean;

{ Other }
function dpmi_set_coprocessor_emulation(flag : longint) : longint;

implementation

{$asmmode ATT}

{$L exceptn.o}

var
  v2prt0_ds_alias : pointer;external name '___v2prt0_ds_alias';
  djgpp_ds_alias  : pointer;external name '___djgpp_ds_alias';
  djgpp_exception_state_ptr : pexception_state;external name '___djgpp_exception_state_ptr';
  endtext        : longint;external name '_etext';
  starttext       : longint;external name 'start';
  djgpp_old_kbd : tseginfo;external name '___djgpp_old_kbd';
  djgpp_hw_lock_start : longint;external name '___djgpp_hw_lock_start';
  djgpp_hw_lock_end : longint;external name '___djgpp_hw_lock_end';
  djgpp_hwint_flags : longint;external name '___djgpp_hwint_flags';
  djgpp_dos_sel : word;external name '___djgpp_dos_sel';
  djgpp_exception_table : array[0..0] of pointer;external name '___djgpp_exception_table';

procedure djgpp_i24;external name '___djgpp_i24';
procedure djgpp_iret;external name '___djgpp_iret';
procedure djgpp_npx_hdlr;external name '___djgpp_npx_hdlr';
procedure djgpp_kbd_hdlr;external name '___djgpp_kbd_hdlr';
procedure djgpp_kbd_hdlr_pc98;external name '___djgpp_kbd_hdlr_pc98';
procedure djgpp_cbrk_hdlr;external name '___djgpp_cbrk_hdlr';


var
  exceptions_on : boolean;
{  old_int00 : tseginfo;cvar;external;
  old_int75 : tseginfo;cvar;external; }

const
  cbrk_vect : byte = $1b;
  exception_level : longint = 0;


{****************************************************************************
                                  Helpers
****************************************************************************}

procedure err(const x : string);
begin
   write(stderr, x);
end;

procedure errln(const x : string);
begin
   writeln(stderr, x);
end;


procedure itox(v,len : longint);
var
  st : string;
begin
  st:=hexstr(v,len);
  err(st);
end;


{****************************************************************************
                              SetJmp/LongJmp
****************************************************************************}

 function c_setjmp(var rec : dpmi_jmp_buf) : longint;[public, alias : '_setjmp'];
  begin
  { here we need to be subtle :
    - we need to return with the arg still on the stack
    - but we also need to jmp to FPC_setjmp and not to call it
    because otherwise the return address is wrong !!

    For this we shift the return address down and
    duplicate the rec on stack }
     asm
        movl    %ebp,%esp
        popl    %ebp
        subl    $8,%esp
        movl    %eax,(%esp)
        movl    8(%esp),%eax
        movl    %eax,4(%esp)
        movl    12(%esp),%eax
        movl    %eax,8(%esp)
        popl    %eax
        jmp     dpmi_setjmp
     end;
  end;


function dpmi_setjmp(var rec : dpmi_jmp_buf) : longint;
begin
  asm
        pushl   %edi
        movl    rec,%edi
        movl    %eax,(%edi)
        movl    %ebx,4(%edi)
        movl    %ecx,8(%edi)
        movl    %edx,12(%edi)
        movl    %esi,16(%edi)
        { load edi }
        movl    -4(%ebp),%eax
        { ... and store it }
        movl    %eax,20(%edi)
        { ebp ... }
        movl    (%ebp),%eax
        movl    %eax,24(%edi)
        { esp ... }
        movl    %esp,%eax
        addl    $12,%eax
        movl    %eax,28(%edi)
        { the return address }
        movl    4(%ebp),%eax
        movl    %eax,32(%edi)
        { flags ... }
        pushfl
        popl    36(%edi)
        { !!!!! the segment registers, not yet needed }
        { you need them if the exception comes from
        an interrupt or a seg_move }
        movw    %cs,40(%edi)
        movw    %ds,42(%edi)
        movw    %es,44(%edi)
        movw    %fs,46(%edi)
        movw    %gs,48(%edi)
        movw    %ss,50(%edi)
        movl    djgpp_exception_state_ptr, %eax
        movl    %eax, 60(%edi)
        { restore EDI }
        pop     %edi
        { we come from the initial call }
        xorl    %eax,%eax
        movl    %eax,__RESULT
        { leave USING RET inside CDECL functions is risky as
        some registers are pushed at entry
        ret  $4 not anymore since cdecl !! }
  end;
end;


procedure c_longjmp(var  rec : dpmi_jmp_buf;return_value : longint);[public, alias : '_longjmp'];
  begin
     dpmi_longjmp(rec,return_value);
     { never gets here !! so pascal stack convention is no problem }
  end;

procedure dpmi_longjmp(var  rec : dpmi_jmp_buf;return_value : longint);[alias : 'FPC_longjmp'];
begin
  if (exception_level>0) then
    dec(exception_level);
  asm
        { restore compiler shit }
        popl    %ebp
        { copy from longjmp.S }
        movl    4(%esp),%edi    { get dpmi_jmp_buf }
        movl    8(%esp),%eax    { store retval in j->eax }
        movl    %eax,0(%edi)

        movw    46(%edi),%fs
        movw    48(%edi),%gs
        movl    4(%edi),%ebx
        movl    8(%edi),%ecx
        movl    12(%edi),%edx
        movl    24(%edi),%ebp
        { Now for some uglyness.  The dpmi_jmp_buf structure may be ABOVE the
           point on the new SS:ESP we are moving to.  We don't allow overlap,
           but do force that it always be valid.  We will use ES:ESI for
           our new stack before swapping to it.  }
        movw    50(%edi),%es
        movl    28(%edi),%esi
        subl    $28,%esi        { We need 7 working longwords on stack }
        movl    60(%edi),%eax
        movl    %eax,%es:(%esi)     { Exception pointer }
        movzwl  42(%edi),%eax
        movl    %eax,%es:4(%esi)    { DS }
        movl    20(%edi),%eax
        movl    %eax,%es:8(%esi)    { EDI }
        movl    16(%edi),%eax
        movl    %eax,%es:12(%esi)   { ESI }
        movl    32(%edi),%eax
        movl    %eax,%es:16(%esi)   { EIP - start of IRET frame }
        movl    40(%edi),%eax
        movl    %eax,%es:20(%esi)   { CS }
        movl    36(%edi),%eax
        movl    %eax,%es:24(%esi)   { EFLAGS }
        movl    0(%edi),%eax
        movw    44(%edi),%es
        movw    50(%edi),%ss
        movl    %esi,%esp
        popl    djgpp_exception_state_ptr
        popl    %ds
        popl    %edi
        popl    %esi
        iret                    { actually jump to new cs:eip loading flags }
  end;
end;


{****************************************************************************
                                 Signals
****************************************************************************}

var
  signal_list : Array[0..SIGMAX] of SignalHandler;

function SIG_ERR(x:longint):longint;
begin
  SIG_ERR:=-1;
end;


function SIG_IGN(x:longint):longint;
begin
  SIG_IGN:=-1;
end;


function SIG_DFL(x:longint):longint;
begin
  SIG_DFL:=0;
end;


function signal(sig : longint;func : SignalHandler) : SignalHandler;
var
  temp : SignalHandler;
begin
  if ((sig <= 0) or (sig > SIGMAX) or (sig = SIGKILL)) then
   begin
     signal:=@SIG_ERR;
     runerror(201);
   end;
  temp := signal_list[sig - 1];
  signal_list[sig - 1] := func;
  signal:=temp;
end;


{ C counter part }
function c_signal(sig : longint;func : SignalHandler) : SignalHandler;cdecl;[public,alias : '_signal'];
var
  temp : SignalHandler;
begin
  temp:=signal(sig,func);
  c_signal:=temp;
end;


const
  signames : array [0..14] of string[4] = (
    'ABRT','FPE ','ILL ','SEGV','TERM','ALRM','HUP ',
    'INT ','KILL','PIPE','QUIT','USR1','USR2','NOFP','TRAP');

function _raise(sig : longint) : longint;
var
  temp : SignalHandler;
label
  traceback_exit;
begin
  if(sig <= 0) or (sig > SIGMAX) then
   exit(-1);
  temp:=signal_list[sig - 1];
  if (temp = SignalHandler(@SIG_IGN)) then
   exit(0);
  if (temp = SignalHandler(@SIG_DFL)) then
   begin
traceback_exit:
     if ((sig >= SIGABRT) and (sig <= SIGTRAP)) then
      begin
        err('Exiting due to signal SIG');
        err(signames[sig-sigabrt]);
      end
     else
      begin
        err('Exiting due to signal $');
        itox(sig, 4);
      end;
     errln('');
     do_faulting_finish_message();   { Exits, does not return }
     exit(-1);
   end;
  { this is incompatible with dxegen-dxeload stuff PM }
  if ((cardinal(temp) < cardinal(@starttext)) or
      (cardinal(temp) > cardinal(@endtext))) then
   begin
     errln('Bad signal handler, ');
     goto traceback_exit;
   end;
  temp(sig);
  exit(0);
end;


function c_raise(sig : longint) : longint;cdecl;[public,alias : '_raise'];
begin
  c_raise:=_raise(sig);
end;


{****************************************************************************
                                 Exceptions
****************************************************************************}

function except_to_sig(excep : longint) : longint;
begin
  case excep of
    5,8,9,11,12,13,14 : exit(SIGSEGV);
    0,4,16            : exit(SIGFPE);
    1,3               : exit(SIGTRAP);
    7                 : exit(SIGNOFP);
  else
    begin
      case excep of
        $75 : exit(SIGFPE);
        $78 : exit(SIGTIMR);
        $1b,
        $79 : exit(SIGINT);
      else
        exit(SIGILL);
      end;
    end;
  end;
end;


procedure show_call_frame(djgpp_exception_state : pexception_state);
begin
  errln('Call frame traceback EIPs:');
  errln('  0x'+hexstr(djgpp_exception_state^.__eip, 8));
  dump_stack(stderr,djgpp_exception_state^.__ebp);
end;


const
  EXCEPTIONCOUNT = 18;
  exception_names : array[0..EXCEPTIONCOUNT-1] of pchar = (
   'Division by Zero',
   'Debug',
   'NMI',
   'Breakpoint',
   'Overflow',
   'Bounds Check',
   'Invalid Opcode',
   'Coprocessor not available',
   'Double Fault',
   'Coprocessor overrun',
   'Invalid TSS',
   'Segment Not Present',
   'Stack Fault',
   'General Protection Fault',
   'Page fault',
   ' ',
   'Coprocessor Error',
   'Alignment Check');

  has_error : array [0..EXCEPTIONCOUNT-1] of byte =
   (0,0,0,0,0,0,0,0,1,0,1,1,1,1,1,0,0,1);

  cbrk_hooked    : boolean = false;
  old_video_mode : byte = 3;


procedure dump_selector(const name : string; sel : word);
var
  base,limit : longint;
begin
  err(name);
  err(': sel=');
  itox(sel, 4);
  if (sel<>0) then
   begin
     base:=get_segment_base_address(sel);
     err('  base='); itox(base, 8);
     limit:=get_segment_limit(sel);
     err('  limit='); itox(limit, 8);
   end;
  errln('');
end;


function farpeekb(sel : word;offset : longint) : byte;
var
  b : byte;
begin
  seg_move(sel,offset,get_ds,longint(@b),1);
  farpeekb:=b;
end;


const message_level : byte = 0;

procedure ___exit(c:byte);cdecl;external name '___exit';

function do_faulting_finish_message : integer;
var
  en : pchar;
  signum,i : longint;
  old_vid : byte;
label
  simple_exit;
begin
  inc(message_level);
  if message_level>2 then
    goto simple_exit;
  do_faulting_finish_message:=0;
  signum:=djgpp_exception_state_ptr^.__signum;
  { check video mode for original here and reset (not if PC98) */ }
  if ((go32_info_block.linear_address_of_primary_screen <> $a0000) and
     (farpeekb(dosmemselector, $449) <> old_video_mode)) then
    begin
       old_vid:=old_video_mode;
       asm
          pusha
          movzbl old_vid,%eax
          int $0x10
          popa
          nop
       end;
    end;

  if (signum >= EXCEPTIONCOUNT) then
    begin
       case signum of
         $75 : en:='Floating Point exception';
         $1b : en:='Control-Break Pressed';
         $79 : en:='Control-C Pressed';
       else
         en:=nil;
       end;
    end
  else
    en:=exception_names[signum];

  if (en = nil) then
    begin
       err('Exception ');
       itox(signum, 2);
       err(' at eip=');
       itox(djgpp_exception_state_ptr^.__eip, 8);
    end
  else
    begin
       write(stderr, 'FPC ',en);
       err(' at eip=');
       itox(djgpp_exception_state_ptr^.__eip, 8);
    end;
  { Control-C should stop the program also !}
  {if (signum = $79) then
    begin
       errln('');
       exit(-1);
    end;}
  if ((signum < EXCEPTIONCOUNT) and (has_error[signum]=1)) then
   begin
     errorcode := djgpp_exception_state_ptr^.__sigmask and $ffff;
     if(errorcode<>0) then
      begin
        err(', error=');
        itox(errorcode, 4);
      end;
   end;
  errln('');
  err('eax=');
  itox(djgpp_exception_state_ptr^.__eax, 8);
  err(' ebx='); itox(djgpp_exception_state_ptr^.__ebx, 8);
  err(' ecx='); itox(djgpp_exception_state_ptr^.__ecx, 8);
  err(' edx='); itox(djgpp_exception_state_ptr^.__edx, 8);
  err(' esi='); itox(djgpp_exception_state_ptr^.__esi, 8);
  err(' edi='); itox(djgpp_exception_state_ptr^.__edi, 8);
  errln('');
  err('ebp='); itox(djgpp_exception_state_ptr^.__ebp, 8);
  err(' esp='); itox(djgpp_exception_state_ptr^.__esp, 8);
  err(' program=');
  errln(paramstr(0));
  dump_selector('cs', djgpp_exception_state_ptr^.__cs);
  dump_selector('ds', djgpp_exception_state_ptr^.__ds);
  dump_selector('es', djgpp_exception_state_ptr^.__es);
  dump_selector('fs', djgpp_exception_state_ptr^.__fs);
  dump_selector('gs', djgpp_exception_state_ptr^.__gs);
  dump_selector('ss', djgpp_exception_state_ptr^.__ss);
  errln('');
  if (djgpp_exception_state_ptr^.__cs = get_cs) then
    show_call_frame(djgpp_exception_state_ptr)
{$ifdef DPMIEXCP_DEBUG}
  else
    errln('Exception occured in another context');
{$endif def DPMIEXCP_DEBUG}
   ;
  if assigned(djgpp_exception_state_ptr^.__exception_ptr) then
    if (djgpp_exception_state_ptr^.__exception_ptr^.__cs = get_cs) then
    begin
       Errln('First exception level stack');
       show_call_frame(djgpp_exception_state_ptr^.__exception_ptr);
    end
{$ifdef DPMIEXCP_DEBUG}
  else
    begin
       errln('First exception occured in another context');
       djgpp_exception_state_ptr:=djgpp_exception_state_ptr^.__exception_ptr;
       do_faulting_finish_message();
    end;
{$endif def DPMIEXCP_DEBUG}
   ;
  { must not return !! }
simple_exit:
  if exceptions_on then
    djgpp_exception_toggle;
  ___exit(1);
end;


function djgpp_exception_state:pexception_state;assembler;
asm
        movl    djgpp_exception_state_ptr,%eax
end;


procedure djgpp_exception_processor;[public,alias : '___djgpp_exception_processor'];
var
  sig : longint;
begin
  if not assigned(djgpp_exception_state_ptr^.__exception_ptr) then
    exception_level:=1
  else
    inc(exception_level);

  sig:=djgpp_exception_state_ptr^.__signum;

  if (exception_level=1) or (sig=$78) then
    begin
       sig := except_to_sig(sig);
       _raise(sig);
       if (djgpp_exception_state_ptr^.__signum >= EXCEPTIONCOUNT) then
         {  Not exception so continue OK }
         dpmi_longjmp(pdpmi_jmp_buf(djgpp_exception_state_ptr)^, djgpp_exception_state_ptr^.__eax);
       { User handler did not exit or longjmp, we must exit }
       err('FPC cannot continue from exception, exiting due to signal ');
       itox(sig, 4);
       errln('');
    end
  else
    begin
       if exception_level>2 then
         begin
            errln('FPC triple exception, exiting !!! ');
            if (exceptions_on) then
              djgpp_exception_toggle;
            asm
               pushw $1
               call  ___exit
            end;
         end;
       err('FPC double exception, exiting due to signal ');
       itox(sig, 4);
       errln('');
    end;
  do_faulting_finish_message;
end;


type
  trealseginfo = tseginfo;
  pseginfo = ^tseginfo;
var
  except_ori : array [0..EXCEPTIONCOUNT-1] of tseginfo;
{$ifdef DPMIEXCP_DEBUG}
   export name '_ori_exceptions';
{$endif def DPMIEXCP_DEBUG}
  kbd_ori    : tseginfo;
  npx_ori    : tseginfo;
  cbrk_ori,
  cbrk_rmcb  : trealseginfo;
  cbrk_regs  : registers;
  v2prt0_exceptions_on : longbool;external name '_v2prt0_exceptions_on';


procedure djgpp_exception_toggle;[alias : '___djgpp_exception_toggle'];
var
  _except : tseginfo;
  i : longint;
begin
{$ifdef DPMIEXCP_DEBUG}
  if exceptions_on then
   errln('Disabling FPC exceptions')
  else
   errln('Enabling FPC exceptions');
{$endif DPMIEXCP_DEBUG}
  { toggle here to avoid infinite recursion }
  { if a subfunction calls runerror !!      }
  exceptions_on:=not exceptions_on;
  v2prt0_exceptions_on:=exceptions_on;
  for i:=0 to EXCEPTIONCOUNT-1 do
   begin
     if get_pm_exception_handler(i,_except) then
      begin
        if (i <> 2) {or (_crt0_startup_flags & _CRT0_FLAG_NMI_SIGNAL))} then
         begin
           if not set_pm_exception_handler(i,except_ori[i]) then
            errln('error setting exception nø'+hexstr(i,2));
         end;
        except_ori[i]:=_except;
      end
     else
      begin
        if get_exception_handler(i,_except) then
         begin
           if (i <> 2) {or (_crt0_startup_flags & _CRT0_FLAG_NMI_SIGNAL))} then
            begin
              if not set_exception_handler(i,except_ori[i]) then
               errln('error setting exception nø'+hexstr(i,2));
            end;
           except_ori[i]:=_except;
         end;
      end;
   end;
  get_pm_interrupt($75,_except);
  set_pm_interrupt($75,npx_ori);
  npx_ori:=_except;
  get_pm_interrupt(9,_except);
  set_pm_interrupt(9,kbd_ori);
  kbd_ori:=_except;
  if (cbrk_hooked) then
   begin
     set_rm_interrupt(cbrk_vect,cbrk_ori);
     free_rm_callback(cbrk_rmcb);
     cbrk_hooked := false;
{$ifdef DPMIEXCP_DEBUG}
     errln('back to ori rm cbrk  '+hexstr(cbrk_ori.segment,4)+':'+hexstr(longint(cbrk_ori.offset),4));
{$endif DPMIEXCP_DEBUG}
   end
  else
   begin
     get_rm_interrupt(cbrk_vect, cbrk_ori);
{$ifdef DPMIEXCP_DEBUG}
     errln('ori rm cbrk  '+hexstr(cbrk_ori.segment,4)+':'+hexstr(longint(cbrk_ori.offset),4));
{$endif DPMIEXCP_DEBUG}
     get_rm_callback(@djgpp_cbrk_hdlr, cbrk_regs, cbrk_rmcb);
     set_rm_interrupt(cbrk_vect, cbrk_rmcb);
{$ifdef DPMIEXCP_DEBUG}
     errln('now rm cbrk  '+hexstr(cbrk_rmcb.segment,4)+':'+hexstr(longint(cbrk_rmcb.offset),4));
{$endif DPMIEXCP_DEBUG}
     cbrk_hooked := true;
   end;
end;


function dpmi_set_coprocessor_emulation(flag : longint) : longint;
var
  res : longint;
begin
  asm
        movl    flag,%ebx
        movl    $0xe01,%eax
        int     $0x31
        jc      .L_coproc_error
        xorl    %eax,%eax
.L_coproc_error:
        movl    %eax,res
  end;
  dpmi_set_coprocessor_emulation:=res;
end;


var
  _swap_in  : pointer;external name '_swap_in';
  _swap_out : pointer;external name '_swap_out';
  _exception_exit : pointer;external name '_exception_exit';

procedure dpmiexcp_exit{(status : longint)};[public,alias : 'excep_exit'];
{ We need to restore hardware interrupt handlers even if somebody calls
  `_exit' directly, or else we crash the machine in nested programs.
  We only toggle the handlers if the original keyboard handler is intact
  (otherwise, they might have already toggled them). }
begin
  if (exceptions_on) then
    djgpp_exception_toggle;
  _exception_exit:=nil;
  _swap_in:=nil;
  _swap_out:=nil;
  { restore the FPU state }
  dpmi_set_coprocessor_emulation(1);
end;

{ _exit in dpmiexcp.c
  is already present in v2prt0.as  PM}

{ used by dos.pp for swap vectors }
procedure dpmi_swap_in;[public,alias : 'swap_in'];
begin
  if not (exceptions_on) then
   djgpp_exception_toggle;
end;


procedure dpmi_swap_out;[public,alias : 'swap_out'];
begin
  if (exceptions_on) then
   djgpp_exception_toggle;
end;


var
  ___djgpp_app_DS : word;external name '___djgpp_app_DS';
  ___djgpp_our_DS : word;external name '___djgpp_our_DS';

procedure djgpp_exception_setup;[alias : '___djgpp_exception_setup'];
var
  temp_kbd,
  temp_npx    : pointer;
  _except,
  old_kbd     : tseginfo;
  locksize    : longint;
  i           : longint;
begin
  if assigned(_exception_exit) then
   exit;
  _exception_exit:=@dpmiexcp_exit;
  _swap_in:=@dpmi_swap_in;
  _swap_out:=@dpmi_swap_out;
{ reset signals }
  for i := 0 to  SIGMAX-1 do
   signal_list[i] := SignalHandler(@SIG_DFL);
{ app_DS only used when converting HW interrupts to exceptions }
  asm
        movw    %ds,___djgpp_app_DS
        movw    %ds,___djgpp_our_DS
  end;
  djgpp_dos_sel:=dosmemselector;
{ lock addresses which may see HW interrupts }
  lock_code(@djgpp_hw_lock_start,@djgpp_hw_lock_end-@djgpp_hw_lock_start);
  _except.segment:=get_cs;
  _except.offset:=@djgpp_exception_table;
  for i:=0 to ExceptionCount-1 do
   begin
     except_ori[i] := _except;    { New value to set }
     inc(_except.offset,4);       { This is the size of push n, jmp }
   end;
  kbd_ori.segment:=_except.segment;
  npx_ori.segment:=_except.segment;
  npx_ori.offset:=@djgpp_npx_hdlr;
  if (go32_info_block.linear_address_of_primary_screen <> $a0000) then
   kbd_ori.offset:=@djgpp_kbd_hdlr
  else
   begin
     kbd_ori.offset:=@djgpp_kbd_hdlr_pc98;
     cbrk_vect := $06;
     _except.offset:=@djgpp_iret;
     set_pm_interrupt($23,_except);
   end;
  _except.offset:=@djgpp_i24;
  set_pm_interrupt($24, _except);
  get_pm_interrupt(9,djgpp_old_kbd);
  djgpp_exception_toggle;    { Set new values & save old values }
{ get original video mode and save }
  old_video_mode := farpeekb(dosmemselector, $449);
end;


function djgpp_set_ctrl_c(enable : boolean) : boolean;
begin
  djgpp_set_ctrl_c:=(djgpp_hwint_flags and 1)=0;
  if enable then
   djgpp_hwint_flags:=djgpp_hwint_flags and (not 1)
  else
   djgpp_hwint_flags:=djgpp_hwint_flags or 1;
end;


function c_djgpp_set_ctrl_c(enable : longint) : boolean;cdecl;[public,alias : '___djgpp_set_ctrl_c'];
begin
  c_djgpp_set_ctrl_c:=djgpp_set_ctrl_c(boolean(enable));
end;



procedure InitDPMIExcp;
begin
  djgpp_ds_alias:=v2prt0_ds_alias;
  djgpp_exception_setup;
end;


begin
  InitDPMIExcp;
end.
{
  $Log$
  Revision 1.11  2000-02-09 16:59:28  peter
    * truncated log

  Revision 1.10  2000/01/10 12:14:57  pierre
   * add $goto on to avoid problems

  Revision 1.9  2000/01/07 16:41:31  daniel
    * copyright 2000

  Revision 1.8  2000/01/07 16:32:23  daniel
    * copyright 2000 added

}