diff --git a/rtl/dos/go32v2/dpmiexcp.pp b/rtl/dos/go32v2/dpmiexcp.pp index f0e1f2174e..ad7f41dd1d 100644 --- a/rtl/dos/go32v2/dpmiexcp.pp +++ b/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; +Unit DPMIExcp; -{$I os.inc} - -{ 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; +{ No stack checking ! } +{$S-} -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 } +{ 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; + 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); -{ /* 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; +{ 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; -{const SIG_DFL = 0;} 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 - -typedef int sig_atomic_t; - -int raise(int _sig); -void (*signal(int _sig, void (*_func)(int)))(int); } - -{ #ifndef __STRICT_ANSI__ - -const SA_NOCLDSTOP 1 - -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; - - - -{ 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 */ } - -type SignalHandler = function (v : 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 + 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; + procedure djgpp_exception_toggle; - -function djgpp_set_ctrl_c(enable : boolean) : boolean; { /* On by default */} - procedure djgpp_exception_setup; +function djgpp_exception_state : pexception_state; +function djgpp_set_ctrl_c(enable : boolean) : boolean; -function djgpp_exception_state : pexception_state; - -function do_faulting_finish_message : integer; - -function setjmp(var rec : tjmprec) : longint; - +{ Other } function dpmi_set_coprocessor_emulation(flag : longint) : longint; -procedure longjmp({const}var rec : tjmprec;return_value : longint); implementation -{$I386_DIRECT} +{$ifdef VER0_99_5} + {$I386_DIRECT} +{$endif} + +{$ASMMODE DIRECT} {$L exceptn.o} -const exceptions_on : boolean = false; +var + exceptions_on : boolean; + starttext, endtext : pointer; -var starttext, endtext : pointer; +{**************************************************************************** + Helpers +****************************************************************************} + +procedure err(const x : string); +begin + write(stderr, x); +{$ifdef VER0_99_5} + flush(stderr); +{$endif} +end; + +procedure errln(const x : string); +begin + writeln(stderr, x); +{$ifdef VER0_99_5} + flush(stderr); +{$endif} +end; + + +procedure itox(v,len : longint); +var + st : string; +begin + st:=hexstr(v,len); + err(st); +end; + + +{**************************************************************************** + SetJmp/LongJmp +****************************************************************************} + +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; + + +const + exception_level : longint = 0; + +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) + + 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; + + +{**************************************************************************** + 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; -{ #include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include /* For DS base/limit info */ -#include } -{ 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 */ } +{**************************************************************************** + Exceptions +****************************************************************************} -{ /* 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; } - -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 = - (0,0,0,0,0,0,0,0,1,0,1,1,1,1,1,0,0,1); const - cbrk_hooked : boolean = false; + 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); +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; - -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; end; -var signal_list : Array[0..SIGMAX] of SignalHandler; - { /* SIG_DFL = 0 */ } -function signal(sig : longint;func : SignalHandler) : SignalHandler; - var temp : SignalHandler; +function farpeekb(sel : word;offset : longint) : byte; +var + b : byte; +begin + seg_move(sel,offset,get_ds,longint(@b),1); + farpeekb:=b; +end; - 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; + 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) 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 + 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); - 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 - 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;} + 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; - -{ /* 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; - - 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; - -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; +end; - procedure djgpp_exception_processor;[public,alias : '___djgpp_exception_processor']; - var sig : longint; +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 + 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 + 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 - 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 - 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 - 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 - 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; -{$ifdef SYSTEMDEBUG} - 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); -{$ifdef SYSTEMDEBUG} - 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); -{$ifdef SYSTEMDEBUG} - errln('now rm cbrk '+hexstr(cbrk_rmcb.segment,4)+':'+hexstr(longint(cbrk_rmcb.offset),4)); -{$endif SYSTEMDEBUG} - cbrk_hooked := true; - end; -{$endif UseRMcbrk} + { 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 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; +{$ifdef UseRMcbrk} + 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)); +{$endif SYSTEMDEBUG} + 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)); +{$endif SYSTEMDEBUG} + 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)); +{$endif SYSTEMDEBUG} + cbrk_hooked := true; + end; +{$endif UseRMcbrk} +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; +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; +begin + if (exceptions_on) then + djgpp_exception_toggle; +end; + 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; - var _except,old_kbd : tseginfo; - locksize : longint; - hw_lock_start, hw_lock_end : longint; - i : longint; - dossel :word; - begin + 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 - 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 + movl temp_kbd,%eax + movl $___djgpp_kbd_hdlr,(%eax) end; - - for i := 0 to SIGMAX-1 do - signal_list[i] := SignalHandler(@SIG_DFL); - - { /* app_DS only used when converting HW interrupts to exceptions */ } + end + else + 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_pc98,(%eax) end; - dossel := dosmemselector; + cbrk_vect := $06; asm - movw dossel,%ax - movw %ax,___djgpp_dos_sel + leal _except,%eax + movl $___djgpp_iret,(%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; - asm - leal _except,%eax - movl $___djgpp_i24,(%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 - .L_already: - end; 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; 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 diff --git a/rtl/dos/go32v2/emu387.pp b/rtl/dos/go32v2/emu387.pp index aa812105c9..d5f64a8550 100644 --- a/rtl/dos/go32v2/emu387.pp +++ b/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 (sandmann@clio.rice.edu) - * 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); - - implementation - - uses dxeload, dpmiexcp, strings; - - type - emu_entry_type = function(exc : pexception_state) : longint; - - var - _emu_entry : emu_entry_type; +procedure npxsetup(prog_name : string); - procedure _control87(mask1,mask2 : word); +implementation - begin -{/* Copyright (C) 1995 DJ Delorie, see COPYING.DJ for details */} +uses + dxeload,dpmiexcp,strings; + +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 } { 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 } + 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, %ecx + notl %ecx + andl %eax, %ecx /* the bits we want to keep */ - movl mask2, %edx - andl mask1, %edx /* the bits we want to change */ + 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; + 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; +{ the problem with the stack that is not cleared } +function emu_entry(exc : pexception_state) : longint; +begin + emu_entry:=_emu_entry(exc); +end; + + +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; - - 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; - end; - - var - prev_exit : pointer; - - procedure restore_DPMI_fpu_state; - begin - exitproc:=prev_exit; + writeln('emu call two times at same address'); dpmi_set_coprocessor_emulation(1); - writeln('Coprocessor restored '); - {/* Enable Coprocessor, no exceptions */} + _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; + dpmi_longjmp(pdpmi_jmp_buf(djgpp_exception_state)^, djgpp_exception_state^.__eax); + nofpsig:=0; +end; - { function _detect_80387 : boolean;[C]; + +var + prev_exit : pointer; + +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; - - procedure npxsetup(prog_name : string); - - var - cp : string; - i : byte; - have_80387 : boolean; - emu_p : pointer; - const - veryfirst : boolean = True; - + if (length(cp)>0) and (upcase(cp[1])='Q') then 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; + if not have_80387 then + write(stderr,'No '); + writeln(stderr,'80387 detected.'); end; + if have_80387 then + begin + { mask all exceptions, except invalid operation } + _control87($033e, $ffff) + end + 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; +end; + begin npxsetup(paramstr(0)); end. - { $Log$ - Revision 1.7 1998-07-22 21:37:51 michael + 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 + + 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 - -} - - -{ - $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 - - - - 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 - ============================================================================= }