* smartlinking the units works now

  * setjmp/longjmp -> dmpi_setjmp/dpmi_longjmp to solve systemunit
    conflict

rtl/dos/go32v2/dpmiexcp.pp

@@ -1,8 +1,9 @@
 {
     $Id$
     This file is part of the Free Pascal run time library.
-    Copyright (c) 1993,97 by Pierre Muller,
-    member of the Free Pascal development team.
+    Copyright (c) 1997-98 by Pierre Muller
+
+    DPMI Exception routines for Go32V2
 
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
@@ -12,199 +13,336 @@
     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
  **********************************************************************}
-{ Translated to FPC pascal by Pierre Muller,
-without changing the exceptn.s file }
-Unit DPMIEXCP;
-
-{$I os.inc}
+Unit DPMIExcp;
 
-{ Real mode control-C check removed
-because I got problems with the RMCB
-can be used by setting this conditionnal (PM) }
-{ works now correctly (PM) }
 {$define UseRMcbrk}
 
 interface
 
-uses go32;
+uses
+  go32;
 
-{$S- no stack check !!! }
-{$packrecords 2 }
-type   tjmprec = record
-          eax,ebx,ecx,edx,esi,edi,ebp,esp,eip,flags : longint;
-          cs,ds,es,fs,gs,ss : word;
-          { we should also save the FPU state, if we use this for excpections }
-          { and the compiler supports FPU register variables }
-       end;
-    type pjmprec = ^tjmprec;
-
-type 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 : longint; {  pointer to previous exception  }
-  __fpu_state : array [0..108-1] of byte; {  for future use  }
+{ No stack checking ! }
+{$S-}
+
+{ Error Messages }
+function do_faulting_finish_message : integer;
+
+{ SetJmp/LongJmp }
+type
+  dpmi_jmp_buf = packed record
+      eax,ebx,ecx,edx,esi,edi,ebp,esp,eip,flags : longint;
+      cs,ds,es,fs,gs,ss : word;
   end;
-    pexception_state = ^texception_state;
-
-{ /* Copyright (C) 1995 DJ Delorie, see COPYING.DJ for details */ }
-{#define __djgpp_exception_state (*__djgpp_exception_state_ptr) }
-const SIGABRT   = 288;
-const SIGFPE    = 289;
-const SIGILL    = 290;
-const SIGSEGV   = 291;
-const SIGTERM   = 292;
-const SIGINT   = 295;
-
-{const SIG_DFL  = 0;}
+  pdpmi_jmp_buf = ^dpmi_jmp_buf;
+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;
-{const SIG_ERR  = -1;
-const SIG_IGN   = -1;}
 
-{ __DJ_pid_t
-#undef __DJ_pid_t
-const __DJ_pid_t
+type
+  SignalHandler  = function (v : longint) : longint;
+  PSignalHandler = SignalHandler; { to be compatible with linux.pp }
 
-typedef int sig_atomic_t;
+function signal(sig : longint;func : SignalHandler) : SignalHandler;
+function _raise(sig : longint) : longint;
 
-int     raise(int _sig);
-void    (*signal(int _sig, void (*_func)(int)))(int); }
+{ Exceptions }
+type
+  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 : longint;  {  pointer to previous exception  }
+    __fpu_state : array [0..108-1] of byte; {  for future use  }
+  end;
+  pexception_state = ^texception_state;
 
-{ #ifndef __STRICT_ANSI__
+procedure djgpp_exception_toggle;
+procedure djgpp_exception_setup;
+function  djgpp_exception_state : pexception_state;
+function  djgpp_set_ctrl_c(enable : boolean) : boolean;
 
-const SA_NOCLDSTOP      1
+{ Other }
+function dpmi_set_coprocessor_emulation(flag : longint) : longint;
 
-const SIGALRM   293
-const SIGHUP    294
-/* SIGINT is ansi */}
-const SIGKILL   = 296;
-const SIGPIPE   = 297;
-const SIGQUIT   = 298;
-const SIGUSR1   = 299;
-const SIGUSR2   = 300;
-{
-const SIG_BLOCK 1
-const SIG_SETMASK       2
-const SIG_UNBLOCK       3 }
 
-const SIGNOFP = 301;
-const SIGTRAP = 302;
-const SIGTIMR = 303;    {/* Internal for setitimer (SIGALRM, SIGPROF) */ }
-const SIGPROF = 304;
-const SIGMAX  = 320;
+implementation
 
+{$ifdef VER0_99_5}
+  {$I386_DIRECT}
+{$endif}
 
+{$ASMMODE DIRECT}
 
-{ extern unsigned short __djgpp_our_DS;
-extern unsigned short __djgpp_app_DS;   /* Data selector invalidated by HW ints */
-extern unsigned short __djgpp_ds_alias; /* Data selector always valid */
-extern unsigned short __djgpp_dos_sel;  /* Linear mem selector copy in locked mem */
-extern unsigned short __djgpp_hwint_flags; /* 1 = Disable Ctrl-C; 2 = Count Ctrl-Break (don't kill) */
-extern unsigned __djgpp_cbrk_count;     /* Count of CTRL-BREAK hits */
-extern int __djgpp_exception_inprog;    /* Nested exception count */ }
+{$L exceptn.o}
 
-type SignalHandler = function (v : longint) : longint;
+var
+  exceptions_on : boolean;
+  starttext, endtext : pointer;
 
-function signal(sig : longint;func : SignalHandler) : SignalHandler;
+{****************************************************************************
+                                  Helpers
+****************************************************************************}
 
-function _raise(sig : longint) : longint;
+procedure err(const x : string);
+begin
+   write(stderr, x);
+{$ifdef VER0_99_5}
+   flush(stderr);
+{$endif}
+end;
 
-procedure djgpp_exception_toggle;
+procedure errln(const x : string);
+begin
+   writeln(stderr, x);
+{$ifdef VER0_99_5}
+   flush(stderr);
+{$endif}
+end;
 
-function  djgpp_set_ctrl_c(enable : boolean) : boolean; {       /* On by default */}
 
-procedure djgpp_exception_setup;
+procedure itox(v,len : longint);
+var
+  st : string;
+begin
+  st:=hexstr(v,len);
+  err(st);
+end;
 
-function djgpp_exception_state : pexception_state;
 
-function do_faulting_finish_message : integer;
+{****************************************************************************
+                              SetJmp/LongJmp
+****************************************************************************}
 
-function setjmp(var rec : tjmprec) : longint;
+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
+        leave
+        ret $4
+  end;
+end;
 
-function dpmi_set_coprocessor_emulation(flag : longint) : longint;
 
-procedure longjmp({const}var rec : tjmprec;return_value : longint);
+const
+  exception_level : longint = 0;
 
-implementation
+procedure dpmi_longjmp(var  rec : dpmi_jmp_buf;return_value : longint);
+begin
+  if (@rec=pdpmi_jmp_buf(djgpp_exception_state)) and (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)
 
-{$I386_DIRECT}
+        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
+        es
+        movl    %eax,(%esi)     { Exception pointer }
+        movzwl  42(%edi),%eax
+        es
+        movl    %eax,4(%esi)    { DS }
+        movl    20(%edi),%eax
+        es
+        movl    %eax,8(%esi)    { EDI }
+        movl    16(%edi),%eax
+        es
+        movl    %eax,12(%esi)   { ESI }
+        movl    32(%edi),%eax
+        es
+        movl    %eax,16(%esi)   { EIP - start of IRET frame }
+        movl    40(%edi),%eax
+        es
+        movl    %eax,20(%esi)   { CS }
+        movl    36(%edi),%eax
+        es
+        movl    %eax,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;
 
-{$L exceptn.o}
 
-const exceptions_on : boolean = false;
+{****************************************************************************
+                                 Signals
+****************************************************************************}
 
-var starttext, endtext : pointer;
+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;
 
-{ #include <libc/stubs.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <unistd.h>
-#include <io.h>
-#include <libc/farptrgs.h>
-#include <dpmi.h>
-#include <go32.h>
-#include <signal.h>
-#include <setjmp.h>
-#include <errno.h>
-#include <crt0.h>
-#include <pc.h>
-#include <sys/exceptn.h>
-#include <sys/nearptr.h>                /* For DS base/limit info */
-#include <libc/internal.h> }
-
-{ const newline = #13#10; }
 
-procedure err(const x : string);
+function signal(sig : longint;func : SignalHandler) : SignalHandler;
+var
+  temp : SignalHandler;
 begin
-   write(stderr, x);
-   flush(stderr);
+  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;
 
-procedure errln(const x : string);
+
+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
-   writeln(stderr, x);
-   flush(stderr);
+  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('');
+   { if(djgpp_exception_state<>nil) then }
+     do_faulting_finish_message();   { Exits, does not return }
+     exit(-1);
+   end;
+  if ((longint(temp) < longint(starttext)) or (longint(temp) > longint(endtext))) then
+   begin
+     errln('Bad signal handler, ');
+     goto traceback_exit;
+   end;
+  temp(sig);
+  exit(0);
 end;
 
-{ extern unsigned end __asm__ ('end'); }
-const cbrk_vect : byte = $1b;
-{       /* May be $06 for PC98 */ }
-
-{ /* These are all defined in exceptn.S and only used here */
-extern int __djgpp_exception_table;
-extern int __djgpp_npx_hdlr;
-extern int __djgpp_kbd_hdlr;
-extern int __djgpp_kbd_hdlr_pc98;
-extern int __djgpp_iret, __djgpp_i24;
-extern void __djgpp_cbrk_hdlr(void);
-extern int __djgpp_hw_lock_start, __djgpp_hw_lock_end;
-extern tseginfo __djgpp_old_kbd; }
+{****************************************************************************
+                                 Exceptions
+****************************************************************************}
 
-procedure itox(v,len : longint);
-  var st : string;
-  begin
-     st:=hexstr(v,len);
-     err(st);
-  end;
+const
+  cbrk_vect : byte = $1b;
 
 function except_to_sig(excep : longint) : longint;
   begin
@@ -227,719 +365,544 @@ function except_to_sig(excep : longint) : longint;
         end;
   end;
 
-  function djgpp_exception_state : pexception_state;
-    begin
-       asm
-          movl ___djgpp_exception_state_ptr,%eax
-          movl %eax,__RESULT
-       end;
-    end;
+{
+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);
+         $75 : exit(SIGFPE);
+         $78 : exit(SIGTIMR);
+     $1b,$79 : exit(SIGINT);
+  else
+   exit(SIGILL);
+  end;
+end;
+}
 
 procedure show_call_frame;
+begin
+  errln('Call frame traceback EIPs:');
+  errln('  0x'+hexstr(djgpp_exception_state^.__eip, 8));
+  dump_stack(djgpp_exception_state^.__ebp);
+end;
 
-  begin
-     errln('Call frame traceback EIPs:');
-     errln('  0x'+hexstr(djgpp_exception_state^.__eip, 8));
-     dump_stack(djgpp_exception_state^.__ebp);
-  end;
 
-const EXCEPTIONCOUNT = 18;
-const 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');
-
-const has_error : array [0..EXCEPTIONCOUNT-1] of byte =
+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);
 
-const
-    cbrk_hooked : boolean = false;
+  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);
+var
+  base,limit : longint;
+begin
+  err(name);
+  err(': sel=');
+  itox(sel, 4);
   if (sel<>0) then
-    begin
-       base:=get_segment_base_address(sel);
-
-       {
-         err('  invalid');
-       }
-       { else }
-
-       err('  base='); itox(base, 8);
-       limit:=get_segment_limit(sel);
-       err('  limit='); itox(limit, 8);
-    end;
+   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 old_video_mode : byte = 3;
+end;
 
-function do_faulting_finish_message : integer;
-  var en : pchar;
-      signum,i : longint;
-      old_vid : byte;
-  begin
-     do_faulting_finish_message:=0;
-     signum:=djgpp_exception_state^.__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
-       en:=nil
-     else
-       en:=exception_names[signum];
-     if (signum = $75) then
-       en:='Floating Point exception';
-     if (signum = $1b) then
-       en:='Control-Break Pressed';
-     if (signum = $79) then
-       en:='Control-C Pressed';
-     if (en = nil) then
-       begin
-          err('Exception ');
-          itox(signum, 2);
-          err(' at eip=');
-          itox(djgpp_exception_state^.__eip, 8);
-       end
-     else
-       begin
-          write(stderr, 'FPC ',en);
-          err(' at eip=');
-          itox(djgpp_exception_state^.__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^.__sigmask and $ffff;
-          if(errorcode<>0) then
-            begin
-               err(', error=');
-               itox(errorcode, 4);
-            end;
-       end;
-     errln('');
-     err('eax=');
-     itox(djgpp_exception_state^.__eax, 8);
-     err(' ebx='); itox(djgpp_exception_state^.__ebx, 8);
-     err(' ecx='); itox(djgpp_exception_state^.__ecx, 8);
-     err(' edx='); itox(djgpp_exception_state^.__edx, 8);
-     err(' esi='); itox(djgpp_exception_state^.__esi, 8);
-     err(' edi='); itox(djgpp_exception_state^.__edi, 8);
-     errln('');
-     err('ebp='); itox(djgpp_exception_state^.__ebp, 8);
-     err(' esp='); itox(djgpp_exception_state^.__esp, 8);
-     err(' program=');
-     errln(paramstr(0));
-     dump_selector('cs', djgpp_exception_state^.__cs);
-     dump_selector('ds', djgpp_exception_state^.__ds);
-     dump_selector('es', djgpp_exception_state^.__es);
-     dump_selector('fs', djgpp_exception_state^.__fs);
-     dump_selector('gs', djgpp_exception_state^.__gs);
-     dump_selector('ss', djgpp_exception_state^.__ss);
-     errln('');
-     if (djgpp_exception_state^.__cs = get_cs) then
-       show_call_frame;
-     { must not return !! }
-     if exceptions_on then
-       djgpp_exception_toggle;
-     asm
-        pushw $1
-        call  ___exit
-     end;
+function farpeekb(sel : word;offset : longint) : byte;
+var
+  b : byte;
+begin
+  seg_move(sel,offset,get_ds,longint(@b),1);
+  farpeekb:=b;
 end;
 
-var  signal_list : Array[0..SIGMAX] of SignalHandler;
- {      /* SIG_DFL = 0 */ }
 
-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);
+function do_faulting_finish_message : integer;
+var
+  en : pchar;
+  signum,i : longint;
+  old_vid : byte;
+begin
+  do_faulting_finish_message:=0;
+  signum:=djgpp_exception_state^.__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;
-     temp := signal_list[sig - 1];
-     signal_list[sig - 1] := func;
-     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');
-
+    end;
 
-function _raise(sig : longint) : longint;
-  var temp : SignalHandler;
-  label traceback_exit;
-  begin
-     if(sig <= 0) then
-       exit(-1);
-  if (sig > SIGMAX) then
-    exit(-1);
-  temp:=signal_list[sig - 1];
-  if (temp = SignalHandler(@SIG_IGN)) then
-    exit(0); {                  /* Ignore it */ }
-  if (temp = SignalHandler(@SIG_DFL)) then
+  if (signum >= EXCEPTIONCOUNT) then
+    en:=nil
+  else
+    en:=exception_names[signum];
+  if (signum = $75) then
+    en:='Floating Point exception';
+  if (signum = $1b) then
+    en:='Control-Break Pressed';
+  if (signum = $79) then
+    en:='Control-C Pressed';
+  if (en = nil) 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('');
-      { if(djgpp_exception_state<>nil) then }
-        do_faulting_finish_message();   {/* Exits, does not return */ }
-      exit(-1);
-    end;
-  if ((longint(temp) < longint(starttext)) or (longint(temp) > longint(endtext))) then
+       err('Exception ');
+       itox(signum, 2);
+       err(' at eip=');
+       itox(djgpp_exception_state^.__eip, 8);
+    end
+  else
     begin
-       errln('Bad signal handler, ');
-       goto traceback_exit;
+       write(stderr, 'FPC ',en);
+       err(' at eip=');
+       itox(djgpp_exception_state^.__eip, 8);
     end;
-  temp(sig);
-  exit(0);
-  end;
-
-{ /* This routine must call exit() or jump changing stacks.  This routine is
-   the basis for traceback generation, core creation, signal handling. */ }
-
-{ taken from sysutils.pas }
-    function setjmp(var rec : tjmprec) : longint;
-
+  { 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^.__sigmask and $ffff;
+     if(errorcode<>0) then
       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
-
-            leave
-            ret $4
-         end;
+        err(', error=');
+        itox(errorcode, 4);
       end;
+   end;
+  errln('');
+  err('eax=');
+  itox(djgpp_exception_state^.__eax, 8);
+  err(' ebx='); itox(djgpp_exception_state^.__ebx, 8);
+  err(' ecx='); itox(djgpp_exception_state^.__ecx, 8);
+  err(' edx='); itox(djgpp_exception_state^.__edx, 8);
+  err(' esi='); itox(djgpp_exception_state^.__esi, 8);
+  err(' edi='); itox(djgpp_exception_state^.__edi, 8);
+  errln('');
+  err('ebp='); itox(djgpp_exception_state^.__ebp, 8);
+  err(' esp='); itox(djgpp_exception_state^.__esp, 8);
+  err(' program=');
+  errln(paramstr(0));
+  dump_selector('cs', djgpp_exception_state^.__cs);
+  dump_selector('ds', djgpp_exception_state^.__ds);
+  dump_selector('es', djgpp_exception_state^.__es);
+  dump_selector('fs', djgpp_exception_state^.__fs);
+  dump_selector('gs', djgpp_exception_state^.__gs);
+  dump_selector('ss', djgpp_exception_state^.__ss);
+  errln('');
+  if (djgpp_exception_state^.__cs = get_cs) then
+    show_call_frame;
+  { must not return !! }
+  if exceptions_on then
+    djgpp_exception_toggle;
+  asm
+     pushw $1
+     call  ___exit
+  end;
+end;
 
-const exception_level : longint = 0;
-
-    procedure longjmp({const}var  rec : tjmprec;return_value : longint);
-
-      begin
-         if (@rec=pjmprec(djgpp_exception_state)) and
-            (exception_level>0) then
-           dec(exception_level);
-         asm
-            { restore compiler shit }
-            popl %ebp
-{/* Copyright (C) 1995 DJ Delorie, see COPYING.DJ for details */}
-{/* This is file LONGJMP.S */}
-        movl    4(%esp),%edi    {/* get 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 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
-        es
-        movl    %eax,(%esi)     {/* Exception pointer */}
-
-        movzwl  42(%edi),%eax
-        es
-        movl    %eax,4(%esi)    {/* DS */}
-
-        movl    20(%edi),%eax
-        es
-        movl    %eax,8(%esi)    {/* EDI */}
-
-        movl    16(%edi),%eax
-        es
-        movl    %eax,12(%esi)   {/* ESI */}
-
-        movl    32(%edi),%eax
-        es
-        movl    %eax,16(%esi)   {/* EIP - start of IRET frame */}
-
-        movl    40(%edi),%eax
-        es
-        movl    %eax,20(%esi)   {/* CS */}
-
-        movl    36(%edi),%eax
-        es
-        movl    %eax,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;
 
+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;
 
+procedure djgpp_exception_processor;[public,alias : '___djgpp_exception_processor'];
+var
+  sig : longint;
+begin
+  inc(exception_level);
+  sig:=djgpp_exception_state^.__signum;
+  if (exception_level=1) or (sig=$78) then
     begin
-       inc(exception_level);
-       sig:=djgpp_exception_state^.__signum;
-       if (exception_level=1) or (sig=$78) then
-         begin
-            sig := except_to_sig(sig);
-            _raise(sig);
-            if (djgpp_exception_state^.__signum >= EXCEPTIONCOUNT) then
-            { /* Not exception so continue OK */ }
-              longjmp(pjmprec(djgpp_exception_state)^, djgpp_exception_state^.__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
+       sig := except_to_sig(sig);
+       _raise(sig);
+       if (djgpp_exception_state^.__signum >= EXCEPTIONCOUNT) then
+         {  Not exception so continue OK }
+         dpmi_longjmp(pdpmi_jmp_buf(djgpp_exception_state)^, djgpp_exception_state^.__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
-            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('');
+            errln('FPC triple exception, exiting !!! ');
+            if (exceptions_on) then
+              djgpp_exception_toggle;
+            asm
+               pushw $1
+               call  ___exit
+            end;
          end;
-       do_faulting_finish_message;
+       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;
-    kbd_ori : tseginfo;
-    npx_ori : tseginfo;
-    cbrk_ori,cbrk_rmcb : trealseginfo;
-    cbrk_regs : registers;
-{/* Routine toggles ALL the exceptions.  Used around system calls, at exit. */}
+type
+  trealseginfo = tseginfo;
+  pseginfo = ^tseginfo;
+var
+  except_ori : array [0..EXCEPTIONCOUNT-1] of tseginfo;
+  kbd_ori    : tseginfo;
+  npx_ori    : tseginfo;
+  cbrk_ori,
+  cbrk_rmcb  : trealseginfo;
+  cbrk_regs  : registers;
 
 function djgpp_cbrk_hdlr : pointer;
-  begin
-     asm
-        movl ___djgpp_cbrk_hdlr,%eax
+begin
+asm
+        movl    ___djgpp_cbrk_hdlr,%eax
         movl %eax,__RESULT
-     end;
-  end;
+end;
+end;
+
 
 function djgpp_old_kbd : pseginfo;
-  begin
-     asm
+begin
+asm
         movl ___djgpp_old_kbd,%eax
         movl %eax,__RESULT
-     end;
-  end;
+end;
+end;
 
 procedure djgpp_exception_toggle;
-  var _except : tseginfo;
-      i : longint;
-      local_ex : boolean;
-
-  begin
+var
+  _except : tseginfo;
+  i : longint;
+  local_ex : boolean;
+begin
 {$ifdef SYSTEMDEBUG}
-     if exceptions_on then
-       begin
-          errln('Disabling FPC exceptions');
-       end
-     else
-       begin
-          errln('Enabling FPC exceptions');
-       end;
+  if exceptions_on then
+   errln('Disabling FPC exceptions')
+  else
+   errln('Enabling FPC exceptions');
 {$endif SYSTEMDEBUG}
-     { toggle here to avoid infinite recursion }
-     { if a subfunction calls runerror !!      }
-     exceptions_on:= not exceptions_on;
-     local_ex:=exceptions_on;
-     asm
-        movzbl local_ex,%eax
-        movl   %eax,_v2prt0_exceptions_on
-     end;
-     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
-               if not set_pm_exception_handler(i,except_ori[i]) then
-                 errln('error setting exception nø'+hexstr(i,2));
-               except_ori[i] := _except;
-            end
-          else
+  { toggle here to avoid infinite recursion }
+  { if a subfunction calls runerror !!      }
+  exceptions_on:=not exceptions_on;
+  local_ex:=exceptions_on;
+  asm
+        movzbl  local_ex,%eax
+        movl    %eax,_v2prt0_exceptions_on
+  end;
+  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 get_exception_handler(i,_except) then
-                 begin
-                    if (i <> 2) {or (_crt0_startup_flags & _CRT0_FLAG_NMI_SIGNAL))} then
-                    if not set_exception_handler(i,except_ori[i]) then
-                      errln('error setting exception nø'+hexstr(i,2));
-                    except_ori[i] := _except;
-                 end
+              if not set_exception_handler(i,except_ori[i]) then
+               errln('error setting exception nø'+hexstr(i,2));
             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;
+           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;
 {$ifdef UseRMcbrk}
-     if (cbrk_hooked) then
-       begin
-          set_rm_interrupt(cbrk_vect,cbrk_ori);
-          free_rm_callback(cbrk_rmcb);
-          cbrk_hooked := false;
+  if (cbrk_hooked) then
+   begin
+     set_rm_interrupt(cbrk_vect,cbrk_ori);
+     free_rm_callback(cbrk_rmcb);
+     cbrk_hooked := false;
 {$ifdef SYSTEMDEBUG}
-       errln('back to ori rm cbrk  '+hexstr(cbrk_ori.segment,4)+':'+hexstr(longint(cbrk_ori.offset),4));
-
+     errln('back to ori rm cbrk  '+hexstr(cbrk_ori.segment,4)+':'+hexstr(longint(cbrk_ori.offset),4));
 {$endif SYSTEMDEBUG}
-       end
-     else
-       begin
-          get_rm_interrupt(cbrk_vect, cbrk_ori);
+   end
+  else
+   begin
+     get_rm_interrupt(cbrk_vect, cbrk_ori);
 {$ifdef SYSTEMDEBUG}
-       errln('ori rm cbrk  '+hexstr(cbrk_ori.segment,4)+':'+hexstr(longint(cbrk_ori.offset),4));
+     errln('ori rm cbrk  '+hexstr(cbrk_ori.segment,4)+':'+hexstr(longint(cbrk_ori.offset),4));
 {$endif SYSTEMDEBUG}
-          get_rm_callback(djgpp_cbrk_hdlr, cbrk_regs, cbrk_rmcb);
-          set_rm_interrupt(cbrk_vect, cbrk_rmcb);
+     get_rm_callback(djgpp_cbrk_hdlr, cbrk_regs, cbrk_rmcb);
+     set_rm_interrupt(cbrk_vect, cbrk_rmcb);
 {$ifdef SYSTEMDEBUG}
-       errln('now rm cbrk  '+hexstr(cbrk_rmcb.segment,4)+':'+hexstr(longint(cbrk_rmcb.offset),4));
+     errln('now rm cbrk  '+hexstr(cbrk_rmcb.segment,4)+':'+hexstr(longint(cbrk_rmcb.offset),4));
 {$endif SYSTEMDEBUG}
-          cbrk_hooked := true;
-       end;
+     cbrk_hooked := true;
+   end;
 {$endif UseRMcbrk}
-  end;
-
-  function dpmi_set_coprocessor_emulation(flag : longint) : longint;
+end;
 
-    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;
+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;
 
 
 procedure dpmiexcp_exit{(status : longint)};[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;
-     asm
-        xorl %eax,%eax
-        movl %eax,_exception_exit
-        movl %eax,_swap_in
-        movl %eax,_swap_out
-     end;
-     { restore the FPU state }
-     dpmi_set_coprocessor_emulation(1);
+{ 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;
+  asm
+        xorl    %eax,%eax
+        movl    %eax,_exception_exit
+        movl    %eax,_swap_in
+        movl    %eax,_swap_out
   end;
+  { restore the FPU state }
+  dpmi_set_coprocessor_emulation(1);
+end;
+
 
 { used by dos.pp for swap vectors }
 procedure dpmi_swap_in;[alias : 'swap_in'];
-  begin
-     if not (exceptions_on) then
-       djgpp_exception_toggle;
-  end;
+begin
+  if not (exceptions_on) then
+   djgpp_exception_toggle;
+end;
 
-procedure dpmi_swap_out;[alias : 'swap_out'];
-  begin
-     if (exceptions_on) then
-       djgpp_exception_toggle;
-  end;
 
-procedure djgpp_exception_setup;
+procedure dpmi_swap_out;[alias : 'swap_out'];
+begin
+  if (exceptions_on) then
+   djgpp_exception_toggle;
+end;
 
-  var _except,old_kbd : tseginfo;
-      locksize : longint;
-      hw_lock_start, hw_lock_end : longint;
-      i : longint;
-      dossel :word;
-  begin
-     asm
-        movl _exception_exit,%eax
-        xorl %eax,%eax
-        jne  .L_already
-        leal excep_exit,%eax
-        movl %eax,_exception_exit
-        leal swap_in,%eax
-        movl %eax,_swap_in
-        leal swap_out,%eax
-        movl %eax,_swap_out
-     end;
 
-     for i := 0 to  SIGMAX-1 do
-        signal_list[i] := SignalHandler(@SIG_DFL);
+procedure djgpp_exception_setup;
+var
+  temp_kbd,
+  temp_npx    : pointer;
+  _except,
+  old_kbd     : tseginfo;
+  locksize    : longint;
+  hw_lock_start,
+  hw_lock_end : longint;
+  i           : longint;
+  dossel      : word;
+begin
+  asm
+        movl    _exception_exit,%eax
+        xorl    %eax,%eax
+        jne     .L_already
+        leal    excep_exit,%eax
+        movl    %eax,_exception_exit
+        leal    swap_in,%eax
+        movl    %eax,_swap_in
+        leal    swap_out,%eax
+        movl    %eax,_swap_out
+  end;
+{ 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
+        movl    $___djgpp_hw_lock_start,%eax
+        movl    %eax,hw_lock_start
+        movl    $___djgpp_hw_lock_end,%eax
+        movl    %eax,hw_lock_end
+  end;
+  dossel := dosmemselector;
+  asm
+        movw    dossel,%ax
+        movw    %ax,___djgpp_dos_sel
+  end;
+{ lock addresses which may see HW interrupts }
+{ lockmem.address = __djgpp_base_address + (unsigned) &__djgpp_hw_lock_start;}
+  locksize := hw_lock_end - hw_lock_start;
+  lock_code(pointer(hw_lock_start),locksize);
+  _except.segment:=get_cs;
+{  _except.offset:= (unsigned) &__djgpp_exception_table;}
+  asm
+         leal   _except,%eax
+         movl   $___djgpp_exception_table,(%eax)
+  end;
+  for i:=0 to ExceptionCount-1 do
+   begin
+     except_ori[i] := _except;    { New value to set }
+     _except.offset:=_except.offset + 4;  { This is the size of push n, jmp }
+   end;
 
-     { /* app_DS only used when converting HW interrupts to exceptions */ }
+  kbd_ori.segment := _except.segment;
+  npx_ori.segment := _except.segment;
+  { make local copy to solve mangledname problem (PFV) }
+  temp_npx:=@npx_ori;
+  temp_kbd:=@kbd_ori;
+  asm
+        movl    temp_npx,%eax
+        movl    $___djgpp_npx_hdlr,(%eax)
+  end;
+  if (go32_info_block.linear_address_of_primary_screen <> $a0000) then
+   begin
      asm
-        movw %ds,___djgpp_app_DS
-        movw %ds,___djgpp_our_DS
-        movl $___djgpp_hw_lock_start,%eax
-        movl %eax,hw_lock_start
-        movl $___djgpp_hw_lock_end,%eax
-        movl %eax,hw_lock_end
+        movl    temp_kbd,%eax
+        movl    $___djgpp_kbd_hdlr,(%eax)
      end;
-     dossel := dosmemselector;
+   end
+  else
+   begin
      asm
-        movw dossel,%ax
-        movw %ax,___djgpp_dos_sel
+        movl    temp_kbd,%eax
+        movl    $___djgpp_kbd_hdlr_pc98,(%eax)
      end;
-     {/* lock addresses which may see HW interrupts */}
-     { lockmem.address = __djgpp_base_address + (unsigned) &__djgpp_hw_lock_start;}
-     locksize := hw_lock_end - hw_lock_start;
-     lock_code(pointer(hw_lock_start),locksize);
-     _except.segment:=get_cs;
-{        _except.offset:= (unsigned) &__djgpp_exception_table;}
-      asm
-         leal _except,%eax
-         movl $___djgpp_exception_table,(%eax)
-      end;
-
-      for i:=0 to EXCEPTIONCOUNT-1 do
-        begin
-           except_ori[i] := _except;    {/* New value to set */}
-           _except.offset:=_except.offset + 4;  {/* This is the size of push n, jmp */}
-        end;
-
-      kbd_ori.segment := _except.segment;
-      npx_ori.segment := _except.segment;
-           asm
-              leal _NPX_ORI,%eax
-              movl $___djgpp_npx_hdlr,(%eax)
-           end;
-      {npx_ori.offset32:= (unsigned) &__djgpp_npx_hdlr;}
-      if (go32_info_block.linear_address_of_primary_screen <> $a0000) then
-        begin
-           asm
-              leal _KBD_ORI,%eax
-              movl $___djgpp_kbd_hdlr,(%eax)
-           end;
-        {kbd_ori.offset32 = (unsigned) &__djgpp_kbd_hdlr;}
-        end
-      else
-        begin
-           asm
-              leal _KBD_ORI,%eax
-              movl $___djgpp_kbd_hdlr_pc98,(%eax)
-           end;
-           {kbd_ori.offset32 = (unsigned) &__djgpp_kbd_hdlr_pc98;}
-           cbrk_vect := $06;
-           asm
-              leal _except,%eax
-              movl $___djgpp_iret,(%eax)
-           end;
-           {_except.offset32 = (unsigned) &__djgpp_iret;                /* TDPMI98 bug */}
-           set_pm_interrupt($23,_except);
-        end;
+     cbrk_vect := $06;
      asm
-        leal _except,%eax
-        movl $___djgpp_i24,(%eax)
+        leal    _except,%eax
+        movl    $___djgpp_iret,(%eax)
      end;
-     {except.offset32 = (unsigned) &__djgpp_i24;}
-     set_pm_interrupt($24, _except);
-     get_pm_interrupt(9,old_kbd);
-     asm
-        movl $___djgpp_old_kbd,%edi
-        leal old_kbd,%esi
-        movl $6,%ecx { sier of tseginfo }
+     set_pm_interrupt($23,_except);
+   end;
+  asm
+        leal    _except,%eax
+        movl    $___djgpp_i24,(%eax)
+  end;
+  set_pm_interrupt($24, _except);
+  get_pm_interrupt(9,old_kbd);
+  asm
+        movl    $___djgpp_old_kbd,%edi
+        leal    old_kbd,%esi
+        movl    $6,%ecx { sier of tseginfo }
         rep
         movsb
-     end;
-     djgpp_exception_toggle;    {/* Set new values & save old values */}
-
-     {/* get original video mode and save */}
-     old_video_mode := farpeekb(dosmemselector, $449);
-     asm
+  end;
+  djgpp_exception_toggle;    { Set new values & save old values }
+{ get original video mode and save }
+  old_video_mode := farpeekb(dosmemselector, $449);
+  asm
         .L_already:
-     end;
   end;
+end;
 
 
 function djgpp_set_ctrl_c(enable : boolean) : boolean;
-  var oldenable : boolean;
+var
+  oldenable : boolean;
 begin
   asm
-     movb ___djgpp_hwint_flags,%al
-     andb $1,%al
-     movb %al,oldenable
+        movb    ___djgpp_hwint_flags,%al
+        andb    $1,%al
+        movb    %al,oldenable
   end;
   if (enable) then
-       asm
-         movl ___djgpp_hwint_flags,%eax
-         andl $0xfffe,%eax
-         movl %eax,___djgpp_hwint_flags
-       end
+    asm
+        movl    ___djgpp_hwint_flags,%eax
+        andl    $0xfffe,%eax
+        movl    %eax,___djgpp_hwint_flags
+    end
   else
-       asm
-         movl ___djgpp_hwint_flags,%eax
-         orl $1,%eax
-         movl %eax,___djgpp_hwint_flags
-       end;
-    {__djgpp_hwint_flags |= 1;}
+    asm
+        movl    ___djgpp_hwint_flags,%eax
+        orl     $1,%eax
+        movl    %eax,___djgpp_hwint_flags
+    end;
+{  __djgpp_hwint_flags |= 1;}
   djgpp_set_ctrl_c:=oldenable;
 end;
 
+
+procedure InitDPMIExcp;
+var
+  tempendtext,
+  tempstarttext : pointer;
 begin
-   asm
-      movl $_etext,_ENDTEXT
-      movl $start,_STARTTEXT
-      movl ___v2prt0_ds_alias,%eax
-      movl %eax,___djgpp_ds_alias
-   end;
-djgpp_exception_setup;
+{ We need to use tempendtext becuase the mangledname of endtext could be
+  different }
+  asm
+        movl    $_etext,tempendtext
+        movl    $start,tempstarttext
+        movl    ___v2prt0_ds_alias,%eax
+        movl    %eax,___djgpp_ds_alias
+  end;
+  endtext:=tempendtext;
+  starttext:=tempstarttext;
+  djgpp_exception_setup;
+end;
+
+
+begin
+  InitDPMIExcp;
 end.
 {
   $Log$
-  Revision 1.6  1998-08-04 13:31:32  pierre
+  Revision 1.7  1998-08-15 17:01:13  peter
+    * smartlinking the units works now
+    * setjmp/longjmp -> dmpi_setjmp/dpmi_longjmp to solve systemunit
+      conflict
+
+  Revision 1.6  1998/08/04 13:31:32  pierre
     * changed all FPK into FPC
 
   Revision 1.5  1998/07/08 12:02:19  carl

rtl/dos/go32v2/emu387.pp

@@ -1,8 +1,9 @@
 {
     $Id$
     This file is part of the Free Pascal run time library.
-    Copyright (c) 1993,97 by Pierre Muller,
-    member of the Free Pascal development team.
+    Copyright (c) 1996-98 by Pierre Muller
+
+    FPU Emulator support
 
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
@@ -12,291 +13,213 @@
     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
  **********************************************************************}
-{ Translated to FPK pascal by Pierre Muller,
-without changing the fpu.s file }
-{
-/* Copyright (C) 1994, 1995 Charles Sandmann ([email protected])
- * FPU setup and emulation hooks for DJGPP V2.0
- * This file maybe freely distributed, no warranty. */
-this file has been translated from
-  npxsetup.c  }
-
 unit emu387;
+interface
 
-  interface
-
-    procedure npxsetup(prog_name : string);
+procedure npxsetup(prog_name : string);
 
-  implementation
 
-    uses dxeload, dpmiexcp, strings;
+implementation
 
-  type
-     emu_entry_type = function(exc : pexception_state) : longint;
+uses
+  dxeload,dpmiexcp,strings;
 
-  var
-     _emu_entry : emu_entry_type;
+type
+  emu_entry_type = function(exc : pexception_state) : longint;
 
+var
+  _emu_entry : emu_entry_type;
 
-  procedure _control87(mask1,mask2 : word);
 
-    begin
-{/* Copyright (C) 1995 DJ Delorie, see COPYING.DJ for details */}
+procedure _control87(mask1,mask2 : word);
+begin
+{ Copyright (C) 1995 DJ Delorie, see COPYING.DJ for details }
 { from file cntrl87.s in src/libc/pc_hw/fpu }
-        asm
-           { make room on stack }
-           pushl   %eax
-           fstcw   (%esp)
-           fwait
-           popl    %eax
-           andl    $0xffff, %eax
-           { OK;  we have the old value ready }
-
-           movl    mask2, %ecx
-           notl    %ecx
-           andl    %eax, %ecx      /* the bits we want to keep */
-
-           movl    mask2, %edx
-           andl    mask1, %edx      /* the bits we want to change */
-
-           orl     %ecx, %edx      /* the new value */
-           pushl   %edx
-           fldcw   (%esp)
-           popl    %edx
-        end;
-    end;
+  asm
+        { make room on stack }
+        pushl   %eax
+        fstcw   (%esp)
+        fwait
+        popl    %eax
+        andl    $0xffff, %eax
+        { OK;  we have the old value ready }
+
+        movl    mask2, %ecx
+        notl    %ecx
+        andl    %eax, %ecx      /* the bits we want to keep */
+
+        movl    mask2, %edx
+        andl    mask1, %edx      /* the bits we want to change */
+
+        orl     %ecx, %edx      /* the new value */
+        pushl   %edx
+        fldcw   (%esp)
+        popl    %edx
+  end;
+end;
+
+
+{ the problem with the stack that is not cleared }
+function emu_entry(exc : pexception_state) : longint;
+begin
+  emu_entry:=_emu_entry(exc);
+end;
 
-     { the problem with the stack that is not cleared }
-  function emu_entry(exc : pexception_state) : longint;
 
+function nofpsig( sig : longint) : longint;
+const
+  last_eip : longint = 0;
+var
+  res : longint;
+begin
+  {if last_eip=djgpp_exception_state^.__eip then
     begin
-       emu_entry:=_emu_entry(exc);
-    end;
-
-  function nofpsig( sig : longint) : longint;
-    var res : longint;
-    const
-       last_eip : longint = 0;
-
+       writeln('emu call two times at same address');
+       dpmi_set_coprocessor_emulation(1);
+       _raise(SIGFPE);
+       exit(0);
+    end; }
+  last_eip:=djgpp_exception_state^.__eip;
+  res:=emu_entry(djgpp_exception_state);
+  if res<>0 then
     begin
-       {if last_eip=djgpp_exception_state^.__eip then
-         begin
-            writeln('emu call two times at same address');
-            dpmi_set_coprocessor_emulation(1);
-            _raise(SIGFPE);
-            exit(0);
-         end; }
-
-       last_eip:=djgpp_exception_state^.__eip;
-       res:=emu_entry(djgpp_exception_state);
-       if res<>0 then
-         begin
-            writeln('emu call failed. res = ',res);
-            dpmi_set_coprocessor_emulation(1);
-            _raise(SIGFPE);
-            exit(0);
-         end;
-       longjmp(pjmprec(djgpp_exception_state)^, djgpp_exception_state^.__eax);
-       nofpsig:=0;
+       writeln('emu call failed. res = ',res);
+       dpmi_set_coprocessor_emulation(1);
+       _raise(SIGFPE);
+       exit(0);
     end;
+  dpmi_longjmp(pdpmi_jmp_buf(djgpp_exception_state)^, djgpp_exception_state^.__eax);
+  nofpsig:=0;
+end;
 
-  var
-     prev_exit : pointer;
 
-  procedure restore_DPMI_fpu_state;
-    begin
-       exitproc:=prev_exit;
-       dpmi_set_coprocessor_emulation(1);
-       writeln('Coprocessor restored ');
-       {/* Enable Coprocessor, no exceptions */}
-    end;
+var
+  prev_exit : pointer;
 
- { function _detect_80387 : boolean;[C];
+procedure restore_DPMI_fpu_state;
+begin
+  exitproc:=prev_exit;
+  { Enable Coprocessor, no exceptions }
+  dpmi_set_coprocessor_emulation(1);
+{$ifdef SYSTEMDEBUG}
+  writeln('Coprocessor restored ');
+{$endif}
+end;
+
+{ function _detect_80387 : boolean;
   not used because of the underscore problem }
 
 {$L fpu.o }
 
 
-  function getenv(const envvar:string):string;
-  { Copied here, preserves uses Dos (PFV) }
-    var
-      hp      : ppchar;
-      hs,
-      _envvar : string;
-      eqpos,i : longint;
+function getenv(const envvar:string):string;
+{ Copied here, preserves uses Dos (PFV) }
+var
+  hp      : ppchar;
+  hs,
+  _envvar : string;
+  eqpos   : longint;
+begin
+  _envvar:=upcase(envvar);
+  hp:=envp;
+  getenv:='';
+  while assigned(hp^) do
+   begin
+     hs:=strpas(hp^);
+     eqpos:=pos('=',hs);
+     if copy(hs,1,eqpos-1)=_envvar then
+      begin
+        getenv:=copy(hs,eqpos+1,255);
+        exit;
+      end;
+     hp:=hp+4;
+   end;
+end;
+
+
+procedure npxsetup(prog_name : string);
+var
+  cp : string;
+  i : byte;
+  have_80387 : boolean;
+  emu_p : pointer;
+const
+  veryfirst : boolean = True;
+begin
+  cp:=getenv('387');
+  if (length(cp)>0) and (upcase(cp[1])='N') then
+    have_80387:=False
+  else
     begin
-      _envvar:=upcase(envvar);
-      hp:=envp;
-      getenv:='';
-      while assigned(hp^) do
-       begin
-         hs:=strpas(hp^);
-         eqpos:=pos('=',hs);
-         if copy(hs,1,eqpos-1)=_envvar then
-          begin
-            getenv:=copy(hs,eqpos+1,255);
-            exit;
-          end;
-         hp:=hp+4;
+       dpmi_set_coprocessor_emulation(1);
+       asm
+          call __detect_80387
+          movb %al,have_80387
        end;
     end;
+  if (length(cp)>0) and (upcase(cp[1])='Q') then
+    begin
+       if not have_80387 then
+         write(stderr,'No ');
+       writeln(stderr,'80387 detected.');
+    end;
 
-  procedure npxsetup(prog_name : string);
-
-    var
-       cp : string;
-       i : byte;
-       have_80387 : boolean;
-       emu_p : pointer; 
-    const
-       veryfirst : boolean = True;
-
+  if have_80387 then
+   begin
+     { mask all exceptions, except invalid operation }
+     _control87($033e, $ffff)
+   end
+  else
     begin
-      cp:=getenv('387');
-      if (length(cp)>0) and (upcase(cp[1])='N') then
-        have_80387:=False
-      else
-        begin
-           dpmi_set_coprocessor_emulation(1);
-           asm
-              call __detect_80387
-              movb %al,have_80387
-           end;
-        end;
-      if (length(cp)>0) and (upcase(cp[1])='Q') then
-        begin
-           if not have_80387 then
-             write(stderr,'No ');
-           writeln(stderr,'80387 detected.');
-        end;
-
-      if have_80387 then
-      {/* mask all exceptions, except invalid operation */}
-        _control87($033e, $ffff)
-      else
-        begin
-           {/* Flags value 3 means coprocessor emulation, exceptions to us */}
-           if (dpmi_set_coprocessor_emulation(3)<>0) then
-             begin
-                writeln(stderr,'Warning: Coprocessor not present and DPMI setup failed!');
-                writeln(stderr,'         If application attempts floating operations system may hang!');
-             end
-           else
-             begin
-                cp:=getenv('EMU387');
-                if length(cp)=0 then
-                  begin
-                     for i:=length(prog_name) downto 1 do
-                       if (prog_name[i]='\') or (prog_name[i]='/') then
-                         break;
-                     if i>1 then
-                       cp:=copy(prog_name,1,i);
-                     cp:=cp+'wmemu387.dxe';
-                  end;
-                emu_p:=dxe_load(cp);
-                _emu_entry:=emu_entry_type(emu_p);
-                if (emu_p=nil) then
-                  begin
-                     writeln(cp+' load failed !');
-                     halt;
-                  end;
-                if veryfirst then
-                  begin
-                     veryfirst:=false;
-                     prev_exit:=exitproc;
-                     exitproc:=@restore_DPMI_fpu_state;
-                  end;
-                signal(SIGNOFP,@nofpsig);
-             end;
-        end;
+       { Flags value 3 means coprocessor emulation, exceptions to us }
+       if (dpmi_set_coprocessor_emulation(3)<>0) then
+         begin
+            writeln(stderr,'Warning: Coprocessor not present and DPMI setup failed!');
+            writeln(stderr,'         If application attempts floating operations system may hang!');
+         end
+       else
+         begin
+            cp:=getenv('EMU387');
+            if length(cp)=0 then
+              begin
+                 for i:=length(prog_name) downto 1 do
+                   if (prog_name[i]='\') or (prog_name[i]='/') then
+                     break;
+                 if i>1 then
+                   cp:=copy(prog_name,1,i);
+                 cp:=cp+'wmemu387.dxe';
+              end;
+            emu_p:=dxe_load(cp);
+            _emu_entry:=emu_entry_type(emu_p);
+            if (emu_p=nil) then
+              begin
+                 writeln(cp+' load failed !');
+                 halt;
+              end;
+            if veryfirst then
+              begin
+                 veryfirst:=false;
+                 prev_exit:=exitproc;
+                 exitproc:=@restore_DPMI_fpu_state;
+              end;
+            signal(SIGNOFP,@nofpsig);
+         end;
     end;
+end;
 
 begin
    npxsetup(paramstr(0));
 end.
-
 {
   $Log$
-  Revision 1.7  1998-07-22 21:37:51  michael
-  + ENViron unknow, replaced by envp
-
-  Revision 1.6  1998/07/21 12:06:56  carl
-    * restored working version
-
-  Revision 1.2  1998/03/26 12:23:17  peter
-    * emu387 doesn't uses dos anymore (getenv copied local)
-    * makefile compilation order changed
-
-  Revision 1.1.1.1  1998/03/25 11:18:42  root
-  * Restored version
-
-  Revision 1.6  1998/03/18 15:34:46  pierre
-    + fpu state is restaured in excep_exit
-      less risk of problems
-
-  Revision 1.5  1998/02/05 17:24:09  pierre
-    * bug in assembler code
-    * changed default name to wmemu387.dxe
-
-  Revision 1.4  1998/02/05 17:04:59  pierre
-    * emulation is working with wmemu387.dxe
-
-  Revision 1.3  1998/01/26 11:57:34  michael
-  + Added log at the end
-
-  Revision 1.2  1998/01/19 17:04:40  pierre
-    * bug in dxe loading corrected, emu still does not work !!
-
-  Revision 1.1  1998/01/16 16:53:15  pierre
-      emu387 is a program based on npxset from DJGPP
-      that loads the emu387.dxe if no FPU is present
-      or if the env var 387 is set to N
+  Revision 1.8  1998-08-15 17:01:14  peter
+    * smartlinking the units works now
+    * setjmp/longjmp -> dmpi_setjmp/dpmi_longjmp to solve systemunit
+      conflict
 
-}
-
-
-{
-  $Log$
-  Revision 1.7  1998-07-22 21:37:51  michael
+  Revision 1.7  1998/07/22 21:37:51  michael
   + ENViron unknow, replaced by envp
 
   Revision 1.6  1998/07/21 12:06:56  carl
     * restored working version
-
-  Revision 1.2  1998/03/26 12:23:17  peter
-    * emu387 doesn't uses dos anymore (getenv copied local)
-    * makefile compilation order changed
-
-  Revision 1.1.1.1  1998/03/25 11:18:42  root
-  * Restored version
-
-  Revision 1.6  1998/03/18 15:34:46  pierre
-    + fpu state is restaured in excep_exit
-      less risk of problems
-
-  Revision 1.5  1998/02/05 17:24:09  pierre
-    * bug in assembler code
-    * changed default name to wmemu387.dxe
-
-  Revision 1.4  1998/02/05 17:04:59  pierre
-    * emulation is working with wmemu387.dxe
-
-  Revision 1.3  1998/01/26 11:57:34  michael
-  + Added log at the end
-
-
-
-  Working file: rtl/dos/go32v2/emu387.pp
-  description:
-  ----------------------------
-  revision 1.2
-  date: 1998/01/19 17:04:40;  author: pierre;  state: Exp;  lines: +11 -2
-    * bug in dxe loading corrected, emu still does not work !!
-  ----------------------------
-  revision 1.1
-  date: 1998/01/16 16:53:15;  author: pierre;  state: Exp;
-      emu387 is a program based on npxset from DJGPP
-      that loads the emu387.dxe if no FPU is present
-      or if the env var 387 is set to N
-  =============================================================================
 }