mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-06-03 08:58:32 +02:00
* smartlinking the units works now
* setjmp/longjmp -> dmpi_setjmp/dpmi_longjmp to solve systemunit
conflict
This commit is contained in:
peter
parent
b2e9bb2cf5
commit
a16e265f27
File diff suppressed because it is too large
Load Diff
@ -1,8 +1,9 @@
|
|||||||
{
|
{
|
||||||
$Id$
|
$Id$
|
||||||
This file is part of the Free Pascal run time library.
|
This file is part of the Free Pascal run time library.
|
||||||
Copyright (c) 1993,97 by Pierre Muller,
|
Copyright (c) 1996-98 by Pierre Muller
|
||||||
member of the Free Pascal development team.
|
|
||||||
|
FPU Emulator support
|
||||||
|
|
||||||
See the file COPYING.FPC, included in this distribution,
|
See the file COPYING.FPC, included in this distribution,
|
||||||
for details about the copyright.
|
for details about the copyright.
|
||||||
@ -12,291 +13,213 @@
|
|||||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
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;
|
unit emu387;
|
||||||
|
interface
|
||||||
|
|
||||||
interface
|
procedure npxsetup(prog_name : string);
|
||||||
|
|
||||||
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 _control87(mask1,mask2 : word);
|
implementation
|
||||||
|
|
||||||
begin
|
uses
|
||||||
{/* Copyright (C) 1995 DJ Delorie, see COPYING.DJ for details */}
|
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 }
|
{ from file cntrl87.s in src/libc/pc_hw/fpu }
|
||||||
asm
|
asm
|
||||||
{ make room on stack }
|
{ make room on stack }
|
||||||
pushl %eax
|
pushl %eax
|
||||||
fstcw (%esp)
|
fstcw (%esp)
|
||||||
fwait
|
fwait
|
||||||
popl %eax
|
popl %eax
|
||||||
andl $0xffff, %eax
|
andl $0xffff, %eax
|
||||||
{ OK; we have the old value ready }
|
{ OK; we have the old value ready }
|
||||||
|
|
||||||
movl mask2, %ecx
|
movl mask2, %ecx
|
||||||
notl %ecx
|
notl %ecx
|
||||||
andl %eax, %ecx /* the bits we want to keep */
|
andl %eax, %ecx /* the bits we want to keep */
|
||||||
|
|
||||||
movl mask2, %edx
|
movl mask2, %edx
|
||||||
andl mask1, %edx /* the bits we want to change */
|
andl mask1, %edx /* the bits we want to change */
|
||||||
|
|
||||||
orl %ecx, %edx /* the new value */
|
orl %ecx, %edx /* the new value */
|
||||||
pushl %edx
|
pushl %edx
|
||||||
fldcw (%esp)
|
fldcw (%esp)
|
||||||
popl %edx
|
popl %edx
|
||||||
end;
|
end;
|
||||||
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
|
begin
|
||||||
emu_entry:=_emu_entry(exc);
|
writeln('emu call two times at same address');
|
||||||
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;
|
|
||||||
dpmi_set_coprocessor_emulation(1);
|
dpmi_set_coprocessor_emulation(1);
|
||||||
writeln('Coprocessor restored ');
|
_raise(SIGFPE);
|
||||||
{/* Enable Coprocessor, no exceptions */}
|
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;
|
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 }
|
not used because of the underscore problem }
|
||||||
|
|
||||||
{$L fpu.o }
|
{$L fpu.o }
|
||||||
|
|
||||||
|
|
||||||
function getenv(const envvar:string):string;
|
function getenv(const envvar:string):string;
|
||||||
{ Copied here, preserves uses Dos (PFV) }
|
{ Copied here, preserves uses Dos (PFV) }
|
||||||
var
|
var
|
||||||
hp : ppchar;
|
hp : ppchar;
|
||||||
hs,
|
hs,
|
||||||
_envvar : string;
|
_envvar : string;
|
||||||
eqpos,i : longint;
|
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
|
begin
|
||||||
_envvar:=upcase(envvar);
|
dpmi_set_coprocessor_emulation(1);
|
||||||
hp:=envp;
|
asm
|
||||||
getenv:='';
|
call __detect_80387
|
||||||
while assigned(hp^) do
|
movb %al,have_80387
|
||||||
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;
|
||||||
end;
|
end;
|
||||||
|
if (length(cp)>0) and (upcase(cp[1])='Q') then
|
||||||
procedure npxsetup(prog_name : string);
|
|
||||||
|
|
||||||
var
|
|
||||||
cp : string;
|
|
||||||
i : byte;
|
|
||||||
have_80387 : boolean;
|
|
||||||
emu_p : pointer;
|
|
||||||
const
|
|
||||||
veryfirst : boolean = True;
|
|
||||||
|
|
||||||
begin
|
begin
|
||||||
cp:=getenv('387');
|
if not have_80387 then
|
||||||
if (length(cp)>0) and (upcase(cp[1])='N') then
|
write(stderr,'No ');
|
||||||
have_80387:=False
|
writeln(stderr,'80387 detected.');
|
||||||
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;
|
|
||||||
end;
|
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
|
begin
|
||||||
npxsetup(paramstr(0));
|
npxsetup(paramstr(0));
|
||||||
end.
|
end.
|
||||||
|
|
||||||
{
|
{
|
||||||
$Log$
|
$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
|
+ ENViron unknow, replaced by envp
|
||||||
|
|
||||||
Revision 1.6 1998/07/21 12:06:56 carl
|
Revision 1.6 1998/07/21 12:06:56 carl
|
||||||
* restored working version
|
* 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
|
|
||||||
=============================================================================
|
|
||||||
}
|
}
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user