paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-07 15:47:53 +02:00
Code Issues Packages Projects Releases Wiki Activity

* force att or direct assembling

Browse Source 
* cleanup of some files
This commit is contained in:
peter 1998-05-31 14:18:12 +00:00
parent 3fe8cd8217
commit 7edd9b8a1e
12 changed files with 781 additions and 1001 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
rtl/dos/crt.pp
View File

@ -161,8 +161,8 @@ var
procedure screensetcursor(row,col : longint);
var
{$ifdef GO32V2}
var
regs : trealregs;
{$endif GO32V2}
begin
@ -869,7 +869,11 @@ end.
{
$Log$
Revision 1.4 1998-05-28 10:21:38 pierre
Revision 1.5 1998-05-31 14:18:12 peter
* force att or direct assembling
* cleanup of some files
Revision 1.4 1998/05/28 10:21:38 pierre
* Handles of input and output restored
Revision 1.3 1998/05/27 00:19:16 peter

36
rtl/dos/dos.pp
View File

@ -4,7 +4,7 @@
Copyright (c) 1993,97 by the Free Pascal development team.
Dos unit for BP7 compatible RTL
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -167,9 +167,10 @@ Procedure Keep(exitcode: word);
implementation
uses
strings;
{$ASMMODE ATT}
{******************************************************************************
--- Dos Interrupt ---
******************************************************************************}
@ -193,6 +194,7 @@ var
end;
{$else GO32V2}
{$ASMMODE DIRECT}
procedure intr(intno : byte;var regs : registers);
begin
@ -247,6 +249,7 @@ var
// FS and GS too
end;
end;
{$ASMMODE ATT}
{$endif GO32V2}
procedure msdos(var regs : registers);
@ -497,7 +500,7 @@ begin
leal b,%ebx
movw $0xff07,%ax
int $0x21
movw %ax,_LASTDOSEXITCODE
movw %ax,LastDosExitCode
end;
end;
@ -639,15 +642,15 @@ end;
for i:=0 to strlen(path) do
if path[i]='/' then path[i]:='\';
asm
movl 18(%ebp),%edx
movl f,%edx
movb $0x1a,%ah
int $0x21
movl 12(%ebp),%edx
movzwl 16(%ebp),%ecx
movl path,%edx
movzwl attr,%ecx
movb $0x4e,%ah
int $0x21
jnc .LFF
movw %ax,U_DOS_DOSERROR
movw %ax,DosError
.LFF:
end;
end;
@ -695,7 +698,7 @@ end;
movb $0x4f,%ah
int $0x21
jnc .LFN
movw %ax,U_DOS_DOSERROR
movw %ax,DosError
.LFN:
end;
end;
@ -711,12 +714,11 @@ end;
end;
procedure swapvectors;
{$ifdef go32v2}
{ uses four global symbols from v2prt0.as
to be able to know the current exception state
without using dpmiexcp unit }
begin
{ uses four global symbols from v2prt0.as to be able to know the current
exception state without using dpmiexcp unit }
{$ASMMODE DIRECT}
begin
asm
movl _exception_exit,%eax
orl %eax,%eax
@ -733,9 +735,9 @@ end;
.Lno_excep:
end;
end;
{$ASMMODE ATT}
{$else not go32v2}
begin
{ only a dummy }
end;
{$endif go32v2}
@ -1009,7 +1011,11 @@ End;
end.
{
$Log$
Revision 1.4 1998-05-22 00:39:22 peter
Revision 1.5 1998-05-31 14:18:13 peter
* force att or direct assembling
* cleanup of some files
Revision 1.4 1998/05/22 00:39:22 peter
* go32v1, go32v2 recompiles with the new objects
* remake3 works again with go32v2
- removed some "optimizes" from daniel which were wrong

151
rtl/dos/go32v1/objinc.inc
View File

@ -1,3 +1,21 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1993-98 by the Free Pascal development team.
Includefile for objects.pp implementing OS-dependent file routines
for Go32V1
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************
}
{---------------------------------------------------------------------------}
{ FileClose -> Platforms DOS - Not checked }
{---------------------------------------------------------------------------}
@ -39,66 +57,6 @@ begin
end;
{---------------------------------------------------------------------------}
{ FileRead -> Platforms DOS - Checked 05May1998 CEC }
{---------------------------------------------------------------------------}
FUNCTION FileRead (Handle: THandle; Var Buf; Count: Sw_Word;
Var Actual: Sw_Word): Word;
BEGIN
asm
movl count,%ecx
movl buf,%edx
xorl %ebx,%ebx
movw handle,%bx
movb $0x3f,%ah
int $0x21
jnc .LDOSREAD1
movw %ax,DosStreamError
xorl %eax,%eax
.LDOSREAD1:
end;
Actual:=Count;
FileRead:=DosStreamError;
end;
{---------------------------------------------------------------------------}
{ FileWrite -> Platforms DOS - Checked 05May1998 CEC }
{---------------------------------------------------------------------------}
FUNCTION FileWrite (Handle: THandle; Var Buf; Count: Sw_Word; Var Actual: Sw_Word): Word;
BEGIN
Actual:=0;
asm
movl Count,%ecx
movl buf,%edx
xorl %ebx,%ebx
movw Handle,%bx
movb $0x40,%ah
pushl %ebp
int $0x21
pop %ebp
jnc .LDOSWRITE1
movw %ax,DosStreamError
.LDOSWRITE1:
end;
Actual:=Count;
FileWrite:=DosStreamError;
end;
{---------------------------------------------------------------------------}
{ SetFileSize -> Platforms DOS - Not Checked }
{---------------------------------------------------------------------------}
FUNCTION SetFileSize (Handle: THandle; FileSize: LongInt): Word;
VAR Actual, Buf: LongInt;
BEGIN
If (Actual = FileSize) Then Begin { No position error }
Actual := FileWrite(Handle, Pointer(@Buf), 0,Actual); { Truncate the file }
If (Actual <> -1) Then SetFileSize := 0 Else { No truncate error }
SetFileSize := 103; { File truncate error }
End Else SetFileSize := 103; { File truncate error }
END;
{***************************************************************************}
{ DosSetFilePtr -> Platforms DOS - Checked 05May1998 CEC }
{***************************************************************************}
@ -131,4 +89,77 @@ BEGIN
END;
{---------------------------------------------------------------------------}
{ FileRead -> Platforms DOS - Checked 05May1998 CEC }
{---------------------------------------------------------------------------}
FUNCTION FileRead (Handle: THandle; Var Buf; Count: Sw_Word;
Var Actual: Sw_Word): Word;
BEGIN
asm
movl count,%ecx
movl buf,%edx
xorl %ebx,%ebx
movw handle,%bx
movb $0x3f,%ah
int $0x21
jnc .LDOSREAD1
movw %ax,DosStreamError
xorl %eax,%eax
.LDOSREAD1:
end;
Actual:=Count;
FileRead:=DosStreamError;
end;
{---------------------------------------------------------------------------}
{ FileWrite -> Platforms DOS - Checked 05May1998 CEC }
{---------------------------------------------------------------------------}
FUNCTION FileWrite (Handle: THandle; Var Buf; Count: Sw_Word; Var Actual: Sw_Word): Word;
BEGIN
Actual:=0;
asm
movl Count,%ecx
movl buf,%edx
xorl %ebx,%ebx
movw Handle,%bx
movb $0x40,%ah
pushl %ebp
int $0x21
pop %ebp
jnc .LDOSWRITE1
movw %ax,DosStreamError
.LDOSWRITE1:
end;
Actual:=Count;
FileWrite:=DosStreamError;
end;
{---------------------------------------------------------------------------}
{ SetFileSize -> Platforms DOS - Not Checked }
{---------------------------------------------------------------------------}
FUNCTION SetFileSize (Handle: THandle; FileSize: LongInt): Word;
VAR Actual, Buf: LongInt;
BEGIN
SetFilePos(Handle,FileSize,0,Actual);
If (Actual = FileSize) Then
Begin
Actual := FileWrite(Handle, Pointer(@Buf), 0,Actual); { Truncate the file }
If (Actual <> -1) Then
SetFileSize := 0
Else
SetFileSize := 103; { File truncate error }
End
Else
SetFileSize := 103; { File truncate error }
END;
{
$Log$
Revision 1.2 1998-05-31 14:18:18 peter
* force att or direct assembling
* cleanup of some files
}

10
rtl/dos/go32v1/system.pp
View File

@ -97,6 +97,7 @@ implementation
{$I system.inc}
{$ASMMODE DIRECT}
procedure int_stackcheck(stack_size:longint);[public,alias: 'STACKCHECK'];
begin
{ called when trying to get local stack
@ -132,10 +133,9 @@ begin
end['EAX','EBX'];
RunError(202);
end;
{$ASMMODE ATT}
{$I386_ATT}
procedure halt(errnum : byte);
begin
do_exit;
@ -582,7 +582,11 @@ Begin
End.
{
$Log$
Revision 1.3 1998-05-22 00:39:33 peter
Revision 1.4 1998-05-31 14:18:19 peter
* force att or direct assembling
* cleanup of some files
Revision 1.3 1998/05/22 00:39:33 peter
* go32v1, go32v2 recompiles with the new objects
* remake3 works again with go32v2
- removed some "optimizes" from daniel which were wrong

273
rtl/dos/go32v2/dpmiexcp.pp
View File

@ -51,19 +51,19 @@ type texception_state = record
{ /* 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 SIGABRT = 288;
const SIGFPE = 289;
const SIGILL = 290;
const SIGSEGV = 291;
const SIGTERM = 292;
const SIGINT = 295;
{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;}
{const SIG_ERR = -1;
const SIG_IGN = -1;}
{ __DJ_pid_t
#undef __DJ_pid_t
@ -71,41 +71,41 @@ const __DJ_pid_t
typedef int sig_atomic_t;
int raise(int _sig);
void (*signal(int _sig, void (*_func)(int)))(int); }
int raise(int _sig);
void (*signal(int _sig, void (*_func)(int)))(int); }
{ #ifndef __STRICT_ANSI__
const SA_NOCLDSTOP 1
const SA_NOCLDSTOP 1
const SIGALRM 293
const SIGHUP 294
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 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 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 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_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 */ }
extern unsigned __djgpp_cbrk_count; /* Count of CTRL-BREAK hits */
extern int __djgpp_exception_inprog; /* Nested exception count */ }
type SignalHandler = function (v : longint) : longint;
@ -115,7 +115,7 @@ function _raise(sig : longint) : longint;
procedure djgpp_exception_toggle;
function djgpp_set_ctrl_c(enable : boolean) : boolean; { /* On by default */}
function djgpp_set_ctrl_c(enable : boolean) : boolean; { /* On by default */}
procedure djgpp_exception_setup;
@ -131,6 +131,8 @@ procedure longjmp({const}var rec : tjmprec;return_value : longint);
implementation
{$ASMMODE DIRECT}
{$L exceptn.o}
const exceptions_on : boolean = false;
@ -166,7 +168,7 @@ end;
#include <crt0.h>
#include <pc.h>
#include <sys/exceptn.h>
#include <sys/nearptr.h> /* For DS base/limit info */
#include <sys/nearptr.h> /* For DS base/limit info */
#include <libc/internal.h> }
{ const newline = #13#10; }
@ -185,7 +187,7 @@ end;
{ extern unsigned end __asm__ ('end'); }
const cbrk_vect : byte = $1b;
{ /* May be $06 for PC98 */ }
{ /* May be $06 for PC98 */ }
{ /* These are all defined in exceptn.S and only used here */
extern int __djgpp_exception_table;
@ -213,7 +215,7 @@ function except_to_sig(excep : longint) : longint;
7 : exit(SIGNOFP);
else
begin
if(excep = $75) then {/* HW int to fake exception values hardcoded in exceptn.S */}
if(excep = $75) then {/* HW int to fake exception values hardcoded in exceptn.S */}
exit(SIGFPE)
else if (excep = $78) then
exit(SIGTIMR)
@ -278,12 +280,12 @@ procedure dump_selector(const name : string; sel : word);
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);
@ -391,7 +393,7 @@ function do_faulting_finish_message : integer;
end;
var signal_list : Array[0..SIGMAX] of SignalHandler;
{ /* SIG_DFL = 0 */ }
{ /* SIG_DFL = 0 */ }
function signal(sig : longint;func : SignalHandler) : SignalHandler;
var temp : SignalHandler;
@ -436,7 +438,7 @@ function _raise(sig : longint) : longint;
exit(-1);
temp:=signal_list[sig - 1];
if (temp = SignalHandler(@SIG_IGN)) then
exit(0); { /* Ignore it */ }
exit(0); { /* Ignore it */ }
if (temp = SignalHandler(@SIG_DFL)) then
begin
traceback_exit:
@ -452,7 +454,7 @@ function _raise(sig : longint) : longint;
end;
errln('');
{ if(djgpp_exception_state<>nil) then }
do_faulting_finish_message(); {/* Exits, does not return */ }
do_faulting_finish_message(); {/* Exits, does not return */ }
exit(-1);
end;
if ((longint(temp) < longint(starttext)) or (longint(temp) > longint(endtext))) then
@ -513,8 +515,8 @@ function _raise(sig : longint) : longint;
movw %gs,48(%edi)
movw %ss,50(%edi)
movl ___djgpp_exception_state_ptr, %eax
movl %eax, 60(%edi)
movl ___djgpp_exception_state_ptr, %eax
movl %eax, 60(%edi)
{ restore EDI }
pop %edi
@ -540,65 +542,65 @@ const exception_level : longint = 0;
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)
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
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. */}
{/* 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 */}
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 */}
movl 60(%edi),%eax
es
movl %eax,(%esi) {/* Exception pointer */}
movzwl 42(%edi),%eax
es
movl %eax,4(%esi) {/* DS */}
movzwl 42(%edi),%eax
es
movl %eax,4(%esi) {/* DS */}
movl 20(%edi),%eax
es
movl %eax,8(%esi) {/* EDI */}
movl 20(%edi),%eax
es
movl %eax,8(%esi) {/* EDI */}
movl 16(%edi),%eax
es
movl %eax,12(%esi) {/* ESI */}
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 32(%edi),%eax
es
movl %eax,16(%esi) {/* EIP - start of IRET frame */}
movl 40(%edi),%eax
es
movl %eax,20(%esi) {/* CS */}
movl 40(%edi),%eax
es
movl %eax,20(%esi) {/* CS */}
movl 36(%edi),%eax
es
movl %eax,24(%esi) {/* EFLAGS */}
movl 36(%edi),%eax
es
movl %eax,24(%esi) {/* EFLAGS */}
movl 0(%edi),%eax
movw 44(%edi),%es
movl 0(%edi),%eax
movw 44(%edi),%es
movw 50(%edi),%ss
movl %esi,%esp
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 */}
popl ___djgpp_exception_state_ptr
popl %ds
popl %edi
popl %esi
iret {/* actually jump to new cs:eip loading flags */}
end;
end;
@ -844,8 +846,8 @@ procedure djgpp_exception_setup;
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 */}
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;
@ -875,7 +877,7 @@ procedure djgpp_exception_setup;
leal _except,%eax
movl $___djgpp_iret,(%eax)
end;
{_except.offset32 = (unsigned) &__djgpp_iret; /* TDPMI98 bug */}
{_except.offset32 = (unsigned) &__djgpp_iret; /* TDPMI98 bug */}
set_pm_interrupt($23,_except);
end;
asm
@ -892,7 +894,7 @@ procedure djgpp_exception_setup;
rep
movsb
end;
djgpp_exception_toggle; {/* Set new values & save old values */}
djgpp_exception_toggle; {/* Set new values & save old values */}
{/* get original video mode and save */}
old_video_mode := farpeekb(dosmemselector, $449);
@ -937,96 +939,11 @@ djgpp_exception_setup;
end.
{
$Log$
Revision 1.2 1998-04-21 14:46:33 pierre
Revision 1.3 1998-05-31 14:18:23 peter
* force att or direct assembling
* cleanup of some files
Revision 1.2 1998/04/21 14:46:33 pierre
+ debug info better output
no normal code changed
Revision 1.1.1.1 1998/03/25 11:18:42 root
* Restored version
Revision 1.9 1998/03/18 15:34:46 pierre
+ fpu state is restaured in excep_exit
less risk of problems
Revision 1.8 1998/03/01 18:18:53 carl
* bugfix of wrong vector initialization because of incorrect
error indexes (were starting at 1 instead of zero in some places).
Revision 1.7 1998/02/05 17:04:58 pierre
* emulation is working with wmemu387.dxe
Revision 1.6 1998/02/03 15:52:49 pierre
* swapvectors really disable exception handling
and interrupt redirection with go32v2
* in dos.pp bug if arg path from fsearch had a directory part fixed
Revision 1.5 1998/01/26 11:57:25 michael
+ Added log at the end
Revision 1.4 1998/01/16 16:49:12 pierre
* Crtl-C did not break the program
}
{
$Log$
Revision 1.2 1998-04-21 14:46:33 pierre
+ debug info better output
no normal code changed
Revision 1.1.1.1 1998/03/25 11:18:42 root
* Restored version
Revision 1.9 1998/03/18 15:34:46 pierre
+ fpu state is restaured in excep_exit
less risk of problems
Revision 1.8 1998/03/01 18:18:53 carl
* bugfix of wrong vector initialization because of incorrect
error indexes (were starting at 1 instead of zero in some places).
Revision 1.7 1998/02/05 17:04:58 pierre
* emulation is working with wmemu387.dxe
Revision 1.6 1998/02/03 15:52:49 pierre
* swapvectors really disable exception handling
and interrupt redirection with go32v2
* in dos.pp bug if arg path from fsearch had a directory part fixed
Revision 1.5 1998/01/26 11:57:25 michael
+ Added log at the end
Working file: rtl/dos/go32v2/dpmiexcp.pp
description:
----------------------------
revision 1.4
date: 1998/01/16 16:49:12; author: pierre; state: Exp; lines: +8 -3
* Crtl-C did not break the program
----------------------------
revision 1.3
date: 1997/12/12 13:14:38; author: pierre; state: Exp; lines: +40 -4
+ added handling of swap_vectors if under exceptions
i.e. swapvector is not dummy under go32v2
* bug in output, exceptions where not allways reset correctly
now the code in dpmiexcp is called from v2prt0.as exit routine
* in crt.pp corrected init_delay calibration loop
and added it for go32v2 also (was disabled before due to crashes !!)
the previous code did a wrong assumption on the time need to call
get_ticks compared to an internal loop without call
----------------------------
revision 1.2
date: 1997/12/01 12:26:08; author: michael; state: Exp; lines: +14 -3
+ added copyright reference in header.
----------------------------
revision 1.1
date: 1997/11/27 08:33:52; author: michael; state: Exp;
Initial revision
----------------------------
revision 1.1.1.1
date: 1997/11/27 08:33:52; author: michael; state: Exp; lines: +0 -0
FPC RTL CVS start
=============================================================================
}

188
rtl/dos/go32v2/dxeload.pp
View File

@ -4,6 +4,8 @@
Copyright (c) 1993,97 by Pierre Muller,
member of the Free Pascal development team.
Unit to Load DXE files for Go32V2
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -11,132 +13,82 @@
but WITHOUT ANY WARRANTY; without even the implied warranty of
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
dxe.h
dxeload.c
npxsetup.c
it uses fpu.as unchanged from fpu.s in DJGPP/SRC/LIBC/}
{/* Copyright (C) 1995 Charles Sandmann (sandmann@clio.rice.edu)
This software may be freely distributed with above copyright, no warranty.
Based on code by DJ Delorie, it's really his, enhanced, bugs fixed. */}
**********************************************************************
}
Unit dxeload;
interface
interface
const
DXE_MAGIC = $31455844;
type
dxe_header = record
magic,
symbol_offset,
element_size,
nrelocs : longint;
end;
type
dxe_header = record
magic : longint;
symbol_offset : longint;
element_size : longint;
nrelocs : longint;
end;
function dxe_load(filename : string) : pointer;
const
DXE_MAGIC = $31455844;
implementation
{/* data stored after dxe_header in file; then relocs, 4 bytes each */}
function dxe_load(filename : string) : pointer;
{
Copyright (C) 1995 Charles Sandmann (sandmann@clio.rice.edu)
translated to Free Pascal by Pierre Muller
}
type
pointer_array = array[0..0] of pointer;
tpa = ^pointer_array;
plongint = ^longint;
ppointer = ^pointer;
var
dh : dxe_header;
data : pchar;
f : file;
relocs : tpa;
i : longint;
addr : plongint;
begin
dxe_load:=nil;
{ open the file }
assign(f,filename);
reset(f,1);
{ load the header }
blockread(f,@dh,sizeof(dxe_header),i);
if (i<>sizeof(dxe_header)) or (dh.magic<>DXE_MAGIC) then
begin
close(f);
exit;
end;
{ get memory for code }
getmem(data,dh.element_size);
if data=nil then
exit;
{ get memory for relocations }
getmem(relocs,dh.nrelocs*sizeof(pointer));
if relocs=nil then
begin
freemem(data,dh.element_size);
exit;
end;
{ copy code }
blockread(f,data^,dh.element_size);
blockread(f,relocs^,dh.nrelocs*sizeof(pointer));
{ relocate internal references }
for i:=0 to dh.nrelocs-1 do
begin
cardinal(addr):=cardinal(data)+cardinal(relocs^[i]);
addr^:=addr^+pointer(data);
end;
dxe_load:=pointer( dh.symbol_offset + cardinal(data));
end;
function dxe_load(filename : string) : pointer;
implementation
function dxe_load(filename : string) : pointer;
type
pointer_array = array[0..0] of pointer;
tpa = ^pointer_array;
plongint = ^longint;
ppointer = ^pointer;
var
dh : dxe_header;
data : pchar;
f : file;
relocs : tpa;
i : longint;
addr : plongint;
begin
dxe_load:=nil;
assign(f,filename);
reset(f,1);
blockread(f,@dh,sizeof(dxe_header));
if dh.magic<>DXE_MAGIC then
begin
close(f);
exit;
end;
{ get memory for code }
getmem(data,dh.element_size);
if data=nil then
exit;
{ get memory for relocations }
getmem(relocs,dh.nrelocs*sizeof(pointer));
if relocs=nil then
begin
freemem(data,dh.element_size);
exit;
end;
{ copy code }
blockread(f,data^,dh.element_size);
blockread(f,relocs^,dh.nrelocs*sizeof(pointer));
{ relocate internal references }
for i:=0 to dh.nrelocs-1 do
begin
cardinal(addr):=cardinal(data)+cardinal(relocs^[i]);
addr^:=addr^+pointer(data);
end;
dxe_load:=pointer( dh.symbol_offset + cardinal(data));
end;
end.
{
$Log$
Revision 1.1 1998-03-25 11:18:42 root
Initial revision
Revision 1.3 1998/01/26 11:57:29 michael
+ Added log at the end
Revision 1.2 1998/01/19 17:04:39 pierre
* bug in dxe loading corrected, emu still does not work !!
Revision 1.1 1998/01/16 16:50:49 pierre
dxeload is a pascal version of the DJGPP C dxe loader
Revision 1.2 1998-05-31 14:18:24 peter
* force att or direct assembling
* cleanup of some files
}
{
$Log$
Revision 1.1 1998-03-25 11:18:42 root
Initial revision
Revision 1.3 1998/01/26 11:57:29 michael
+ Added log at the end
Working file: rtl/dos/go32v2/dxeload.pp
description:
----------------------------
revision 1.2
date: 1998/01/19 17:04:39; author: pierre; state: Exp; lines: +7 -3
* bug in dxe loading corrected, emu still does not work !!
----------------------------
revision 1.1
date: 1998/01/16 16:50:49; author: pierre; state: Exp;
dxeload is a pascal version of the DJGPP C dxe loader
=============================================================================
}

426
rtl/dos/go32v2/emu387.pp
View File

@ -4,6 +4,8 @@
Copyright (c) 1993,97 by Pierre Muller,
member of the Free Pascal development team.
Loads the emu387 Fpu emulator
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -12,204 +14,200 @@
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);
procedure npxsetup(prog_name : string);
implementation
implementation
uses
dxeload,dpmiexcp;
uses dxeload, dpmiexcp;
{$ASMMODE ATT}
type
emu_entry_type = function(exc : pexception_state) : longint;
const
defaultdxe = 'wmemu387.dxe';
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);
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;
begin
{/* Copyright (C) 1995 DJ Delorie, see COPYING.DJ for details */}
procedure _control87(mask1,mask2 : word);
{ 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 }
begin
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;
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 */
function emu_entry(exc : pexception_state) : longint;
{
the problem with the stack that is not cleared
}
begin
emu_entry:=_emu_entry(exc);
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;
function nofpsig( sig : longint) : longint;
var
res : longint;
const
last_eip : longint = 0;
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 */}
end;
_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);
{ writeln('Coprocessor restored '); }
{ Enable Coprocessor, no exceptions }
end;
{ function _detect_80387 : boolean;[C];
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 : longint;
procedure npxsetup(prog_name : string);
const
veryfirst : boolean = True;
var
cp : string;
i : byte;
have_80387 : boolean;
emu_p : pointer;
begin
cp:=getenv('387');
if (cp<>'') 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);
{$ASMMODE DIRECT}
asm
call __detect_80387
movb %al,have_80387
end;
{$ASMMODE ATT}
end;
procedure npxsetup(prog_name : string);
var
cp : string;
i : byte;
have_80387 : boolean;
emu_p : pointer;
const
veryfirst : boolean = True;
if (cp<>'') 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 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
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
{/* 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;
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 cp='' 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+defaultdxe
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));
@ -217,92 +215,8 @@ end.
{
$Log$
Revision 1.4 1998-05-21 19:30:51 peter
* objects compiles for linux
+ assign(pchar), assign(char), rename(pchar), rename(char)
* fixed read_text_as_array
+ read_text_as_pchar which was not yet in the rtl
Revision 1.3 1998/03/31 10:18:55 florian
* exit message removed
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.5 1998-05-31 14:18:25 peter
* force att or direct assembling
* cleanup of some files
}
{
$Log$
Revision 1.4 1998-05-21 19:30:51 peter
* objects compiles for linux
+ assign(pchar), assign(char), rename(pchar), rename(char)
* fixed read_text_as_array
+ read_text_as_pchar which was not yet in the rtl
Revision 1.3 1998/03/31 10:18:55 florian
* exit message removed
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
=============================================================================
}

129
rtl/dos/go32v2/objinc.inc
View File

@ -1,3 +1,21 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1993-98 by the Free Pascal development team.
Includefile for objects.pp implementing OS-dependent file routines
for Go32V2
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************
}
{---------------------------------------------------------------------------}
{ FileClose -> Platforms DOS - Not checked }
{---------------------------------------------------------------------------}
@ -11,13 +29,14 @@ begin
FileClose := 0;
end;
{---------------------------------------------------------------------------}
{ FileOpen -> Platforms DOS - Checked 05May1998 CEC }
{ Returns 0 on failure }
{---------------------------------------------------------------------------}
FUNCTION FileOpen (Var FileName: AsciiZ; Mode: Word): THandle;
Var
var regs : trealregs;
regs : trealregs;
BEGIN
DosStreamError:=0;
syscopytodos(longint(@FileName),256);
@ -38,6 +57,48 @@ BEGIN
FileOpen:=regs.realeax and $ffff;
END;
{---------------------------------------------------------------------------}
{ SetFilePos -> Platforms DOS - Checked 05May1998 CEC }
{---------------------------------------------------------------------------}
{
Calls the operating system to move the file denoted by the handle to
to the requested position. The move method can be: 0 = absolute offset;
1 = offset from present location; 2 = offset from end of file;
Any error is held in DosErrorStream and returned from the call.
If the return is zero (ie no error) NewPos contains the new absolute
file position.
}
FUNCTION SetFilePos (Handle: THandle; Pos: LongInt; MoveType: Word;Var Actual: LongInt): Word;
Var
regs: Trealregs;
const
CarryFlag = $001;
BEGIN
regs.realeax := ($42 shl 8) + Byte(MoveType);
regs.realedx := pos and $ffff; { keep low word }
regs.realecx := pos shr 16;
regs.realebx := longint(Handle);
sysrealintr($21,regs);
if (regs.RealFlags and CarryFlag = 0) then { no error }
Actual:=(regs.realeax and $ffff) + ((regs.realedx and $ffff) shl 16)
else
DosStreamError:=word(regs.realeax);
SetFilePos := DosStreamError; { Return any error }
END;
{---------------------------------------------------------------------------}
{ FileRead -> Platforms DOS - Checked 05May1998 CEC }
{---------------------------------------------------------------------------}
FUNCTION FileRead (Handle: THandle; Var Buf; Count: Sw_Word;
Var Actual: Sw_Word): Word;
BEGIN
Actual:=system.do_read(longint(Handle),longint(@Buf),Count);
FileRead:=InOutRes;
End;
{---------------------------------------------------------------------------}
{ FileWrite -> Platforms DOS - Checked 05May1998 CEC }
{---------------------------------------------------------------------------}
@ -55,57 +116,23 @@ End;
FUNCTION SetFileSize (Handle: THandle; FileSize: LongInt): Word;
VAR Actual, Buf: LongInt;
BEGIN
If (Actual = FileSize) Then Begin { No position error }
Actual := FileWrite(Handle, Pointer(@Buf), 0,Actual); { Truncate the file }
If (Actual <> -1) Then SetFileSize := 0 Else { No truncate error }
SetFilePos(Handle,FileSize,0,Actual);
If (Actual = FileSize) Then
Begin
Actual := FileWrite(Handle, Pointer(@Buf), 0,Actual); { Truncate the file }
If (Actual <> -1) Then
SetFileSize := 0
Else
SetFileSize := 103; { File truncate error }
End Else SetFileSize := 103; { File truncate error }
End
Else
SetFileSize := 103; { File truncate error }
END;
{
$Log$
Revision 1.2 1998-05-31 14:18:26 peter
* force att or direct assembling
* cleanup of some files
{---------------------------------------------------------------------------}
{ FileRead -> Platforms DOS - Checked 05May1998 CEC }
{---------------------------------------------------------------------------}
FUNCTION FileRead (Handle: THandle; Var Buf; Count: Sw_Word;
Var Actual: Sw_Word): Word;
BEGIN
Actual:=system.do_read(longint(Handle),longint(@Buf),Count);
FileRead:=InOutRes;
End;
{***************************************************************************}
{ DosSetFilePtr -> Platforms DOS - Checked 05May1998 CEC }
{***************************************************************************}
{=DosSetFilePtr======================================================
Calls the operating system to move the file denoted by the handle to
to the requested position. The move method can be: 0 = absolute offset;
1 = offset from present location; 2 = offset from end of file;
Any error is held in DosErrorStream and returned from the call.
If the return is zero (ie no error) NewPos contains the new absolute
file position.
-> Platforms DOS/DPMI/WIN - Checked 16May96 LdB}
FUNCTION SetFilePos (Handle: THandle; Pos: LongInt; MoveType: Word;
Var Actual: LongInt): Word;
Var
regs: Trealregs;
const
CarryFlag = $001;
BEGIN
regs.realeax := ($42 shl 8) + Byte(MoveType);
{ regs.realah := $42;
regs.realal := Byte(MoveType); }
regs.realedx := pos and $ffff; { keep low word }
regs.realecx := pos shr 16;
regs.realebx := longint(Handle);
sysrealintr($21,regs);
if (regs.RealFlags and CarryFlag = 0) then { no error }
Actual:=(regs.realeax and $ffff) + ((regs.realedx and $ffff) shl 16)
else
DosStreamError:=word(regs.realeax);
SetFilePos := DosStreamError; { Return any error }
END;
}

27
rtl/dos/go32v2/os.inc
View File

@ -11,7 +11,7 @@
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{$undef dos}
{$undef go32v1}
{$define go32v2}
{$undef os2}
{$undef linux}
@ -19,27 +19,8 @@
{
$Log$
Revision 1.1 1998-03-25 11:18:42 root
Initial revision
Revision 1.2 1998-05-31 14:18:27 peter
* force att or direct assembling
* cleanup of some files
Revision 1.3 1998/01/26 11:57:12 michael
+ Added log at the end
Working file: rtl/dos/go32v2/os.inc
description:
----------------------------
revision 1.2
date: 1997/12/01 15:35:00; author: michael; state: Exp; lines: +13 -0
+ Added copyright reference in header.
----------------------------
revision 1.1
date: 1997/11/27 08:33:52; author: michael; state: Exp;
Initial revision
----------------------------
revision 1.1.1.1
date: 1997/11/27 08:33:52; author: michael; state: Exp; lines: +0 -0
FPC RTL CVS start
=============================================================================
}

359
rtl/dos/go32v2/profile.pp
View File

@ -1,9 +1,11 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1993,97 by Pierre Muller,
Copyright (c) 1993-98 by Pierre Muller,
member of the Free Pascal development team.
Profiling support for Go32V2
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -11,105 +13,99 @@
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
**********************************************************************
}
Unit profile;
{$I os.inc}
interface
uses go32,dpmiexcp;
type header = record
low,high,nbytes : longint;
end;
{/* entry of a GPROF type file
*/}
type MTABE = record
from,_to,count : longint;
end;
pMTABE = ^MTABE;
ppMTABE = ^pMTABE;
{/* internal form - sizeof(MTAB) is 4096 for efficiency
*/ }
type
header = record
low,high,nbytes : longint;
end;
{ entry of a GPROF type file }
ppMTABE = ^pMTABE;
pMTABE = ^MTABE;
MTABE = record
from,_to,count : longint;
end;
{ internal form - sizeof(MTAB) is 4096 for efficiency }
PMTAB = ^M_TAB;
M_TAB = record
calls : array [0..340] of MTABE;
prev : PMTAB;
end;
var
h : header;
histogram : ^integer;
const
mcount_skip : longint = 1;
var
histlen : longint;
oldexitproc : pointer;
calls : array [0..340] of MTABE;
prev : PMTAB;
end;
const
mtab : PMTAB = nil;
mcount_skip : longint = 1;
mtab : PMTAB = nil;
var
h : header;
histogram : ^integer;
histlen : longint;
oldexitproc : pointer;
{/* called by functions. Use the pointer it provides to cache
** the last used MTABE, so that repeated calls to/from the same
** pair works quickly - no lookup.
*/ }
{ called by functions. Use the pointer it provides to cache the last used
MTABE, so that repeated calls to/from the same pair works quickly -
no lookup. }
procedure mcount;
implementation
type plongint = ^longint;
uses
go32,dpmiexcp;
var starttext, endtext : longint;
{$ASMMODE ATT}
const cache : pMTABE = nil;
type
plongint = ^longint;
var
starttext, endtext : longint;
const
cache : pMTABE = nil;
{ ebp contains the frame of mcount)
(ebp) the frame of calling (to_)
((ebp)) the frame of from }
{ problem how to avoid mcount calling itself !! }
procedure mcount; [public, alias : 'MCOUNT'];
var
m : pmtab;
i,to_,ebp,from,mtabi : longint;
begin
{ optimisation !! }
asm
pushal
movl 4(%ebp),%eax
movl %eax,to_
movl (%ebp),%eax
movl 4(%eax),%eax
movl %eax,from
end;
if endtext=0 then
asm
popal
leave
ret
end;
mcount_skip := 1;
if (to_ > endtext) or (from > endtext) then runerror(255);
if ((cache<>nil) and
(cache^.from=from) and
(cache^._to=to_)) then
begin
{/* cache paid off - works quickly */}
{ problem how to avoid mcount calling itself !! }
procedure mcount; [public, alias : 'MCOUNT'];
{
ebp contains the frame of mcount (ebp) the frame of calling (to_)
((ebp)) the frame of from
}
var
m : pmtab;
i,to_,ebp,from,mtabi : longint;
begin
{ optimisation !! }
asm
pushal
movl 4(%ebp),%eax
movl %eax,to_
movl (%ebp),%eax
movl 4(%eax),%eax
movl %eax,from
end;
if endtext=0 then
asm
popal
leave
ret
end;
mcount_skip := 1;
if (to_ > endtext) or (from > endtext) then
runerror(255);
if ((cache<>nil) and (cache^.from=from) and (cache^._to=to_)) then
begin
{ cache paid off - works quickly }
inc(cache^.count);
mcount_skip:=0;
asm
popal
leave
ret
popal
leave
ret
end;
end;
{/* no cache hit - search all mtab tables for a match, or an empty slot */}
end;
{ no cache hit - search all mtab tables for a match, or an empty slot }
mtabi := -1;
m:=mtab;
while m<>nil do
@ -118,14 +114,13 @@ const cache : pMTABE = nil;
begin
if m^.calls[i].from=0 then
begin
{/* empty slot - end of table */ }
{ empty slot - end of table }
mtabi := i;
break;
end;
if ((m^.calls[i].from = from) and
(m^.calls[i]._to = to_)) then
if ((m^.calls[i].from = from) and (m^.calls[i]._to = to_)) then
begin
{/* found a match - bump count and return */}
{ found a match - bump count and return }
inc(m^.calls[i].count);
cache:=@(m^.calls[i]);
mcount_skip:=0;
@ -140,7 +135,7 @@ const cache : pMTABE = nil;
end;
if (mtabi<>-1) then
begin
{/* found an empty - fill it in */}
{ found an empty - fill it in }
mtab^.calls[mtabi].from := from;
mtab^.calls[mtabi]._to := to_;
mtab^.calls[mtabi].count := 1;
@ -152,7 +147,7 @@ const cache : pMTABE = nil;
ret
end;
end;
{/* lob off another page of memory and initialize the new table */}
{ lob off another page of memory and initialize the new table }
getmem(m,sizeof(M_TAB));
fillchar(m^, sizeof(M_TAB),#0);
m^.prev := mtab;
@ -167,31 +162,40 @@ const cache : pMTABE = nil;
leave
ret
end;
end;
end;
var new_timer,old_timer : tseginfo;
{ from itimer.c
/* Copyright (C) 1995 Charles Sandmann (sandmann@clio.rice.edu)
setitimer implmentation - used for profiling and alarm
BUGS: ONLY ONE AT A TIME, first pass code
This software may be freely distributed, no warranty. */ }
var
new_timer,
old_timer : tseginfo;
invalid_mcount_call,
mcount_nb,
doublecall,
reload : longint; {=0}
{ static void timer_action(int signum) }
{
if(reload)
__djgpp_timer_countdown = reload;
else
stop_timer();
raise(sigtype);
}
var reload : longint;
const invalid_mcount_call : longint = 0;
mcount_nb : longint = 0;
doublecall : longint = 0;
function mcount_tick(x : longint) : longint;
var
bin : longint;
begin
if mcount_skip=0 then
begin
bin := djgpp_exception_state^.__eip;
if (djgpp_exception_state^.__cs=get_cs) and (bin >= starttext) and (bin <= endtext) then
begin
bin := (bin - starttext) div 16;
inc(histogram[bin]);
end
else
inc(invalid_mcount_call);
inc(mcount_nb);
end
else
inc(doublecall);
mcount_tick:=0;
end;
function mcount_tick(x : longint) : longint;forward;
{$ASMMODE DIRECT}
function timer(x : longint) : longint;
begin
if reload>0 then
@ -199,28 +203,20 @@ begin
movl _RELOAD,%eax
movl %eax,___djgpp_timer_countdown
end;
mcount_tick(x);
{ _raise(SIGPROF); }
end;
{/* this is called during program exit (installed by atexit). */}
procedure mcount_write;
var m : PMTAB;
i : longint;
f : file;
{
MTAB *m;
int i, f;
struct itimerval new_values;
mcount_skip = 1;
/* disable timer */
new_values.it_value.tv_usec = new_values.it_interval.tv_usec = 0;
new_values.it_value.tv_sec = new_values.it_interval.tv_sec = 0;
setitimer(ITIMER_PROF, &new_values, NULL); }
begin
this is called during program exit
}
var
m : PMTAB;
i : longint;
f : file;
begin
mcount_skip:=1;
signal(SIGTIMR,@SIG_IGN);
signal(SIGPROF,@SIG_IGN);
@ -257,41 +253,11 @@ procedure mcount_write;
close(f);
end;
(* extern unsigned start __asm__ ("start");
#define START (unsigned)&start
extern int etext;
/* ARGSUSED */
static void *)
function mcount_tick(x : longint) : longint;
var bin : longint;
begin
if mcount_skip=0 then
begin
{bin = __djgpp_exception_state->__eip;}
bin := djgpp_exception_state^.__eip;
if (djgpp_exception_state^.__cs=get_cs) and
(bin >= starttext) and (bin <= endtext) then
begin
{bin := (bin - starttext) div 4;} {/* 4 EIP's per bin */}
bin := (bin - starttext) div 16;
inc(histogram[bin]);
end
else
inc(invalid_mcount_call);
inc(mcount_nb);
end
else
inc(doublecall);
mcount_tick:=0;
end;
{/* this is called to initialize profiling before the program starts */}
procedure _mcount_init;
{struct itimerval new_values;}
procedure mcount_init;
{
this is called to initialize profiling before the program starts
}
function djgpp_timer_hdlr : pointer;
begin
@ -311,14 +277,13 @@ procedure _mcount_init;
movw 4(%eax),%ax
movw %ax,4(%ebx)
end;
end;
begin
asm
movl $_etext,_ENDTEXT
movl $start,_STARTTEXT
end;
begin
asm
movl $_etext,_ENDTEXT
movl $start,_STARTTEXT
end;
h.low := starttext;
h.high := endtext;
histlen := ((h.high-h.low) div 16) * 2; { must be even }
@ -329,79 +294,41 @@ begin
oldexitproc:=exitproc;
exitproc:=@mcount_write;
{/* here, do whatever it takes to initialize the timer interrupt */}
{ here, do whatever it takes to initialize the timer interrupt }
signal(SIGPROF,@mcount_tick);
signal(SIGTIMR,@timer);
get_pm_interrupt($8,old_timer);
set_old_timer_handler;
{$ifdef DEBUG}
writeln(stderr,'ori pm int8 '+hexstr(old_timer.segment,4)+':'
+hexstr(longint(old_timer.offset),8));
flush(stderr);
writeln(stderr,'ori pm int8 '+hexstr(old_timer.segment,4)+':'+hexstr(longint(old_timer.offset),8));
flush(stderr);
{$endif DEBUG}
new_timer.segment:=get_cs;
new_timer.offset:=djgpp_timer_hdlr;
reload:=3;
{$ifdef DEBUG}
writeln(stderr,'new pm int8 '+hexstr(new_timer.segment,4)+':'
+hexstr(longint(new_timer.offset),8));
flush(stderr);
writeln(stderr,'new pm int8 '+hexstr(new_timer.segment,4)+':'+hexstr(longint(new_timer.offset),8));
flush(stderr);
{$endif DEBUG}
set_pm_interrupt($8,new_timer);
reload:=1;
asm
movl _RELOAD,%eax
movl %eax,___djgpp_timer_countdown
end;
mcount_skip := 0;
asm
movl _RELOAD,%eax
movl %eax,___djgpp_timer_countdown
end;
mcount_skip := 0;
end;
{$ASMMODE ATT}
begin
_mcount_init;
mcount_init;
end.
{
$Log$
Revision 1.1 1998-03-25 11:18:42 root
Initial revision
Revision 1.4 1998/01/26 11:57:39 michael
+ Added log at the end
Revision 1.3 1998/01/16 16:54:22 pierre
+ logs added at end
+ dxeload and emu387 added in makefile
Revision 1.2 1998-05-31 14:18:28 peter
* force att or direct assembling
* cleanup of some files
}
{
$Log$
Revision 1.1 1998-03-25 11:18:42 root
Initial revision
Revision 1.4 1998/01/26 11:57:39 michael
+ Added log at the end
Working file: rtl/dos/go32v2/profile.pp
description:
----------------------------
revision 1.3
date: 1998/01/16 16:54:22; author: pierre; state: Exp; lines: +5 -2
+ logs added at end
+ dxeload and emu387 added in makefile
----------------------------
revision 1.2
date: 1997/12/01 12:26:09; author: michael; state: Exp; lines: +14 -3
+ added copyright reference in header.
----------------------------
revision 1.1
date: 1997/11/27 08:33:52; author: michael; state: Exp;
Initial revision
----------------------------
revision 1.1.1.1
date: 1997/11/27 08:33:52; author: michael; state: Exp; lines: +0 -0
FPC RTL CVS start
=============================================================================
}

85
rtl/dos/go32v2/system.pp
View File

@ -124,13 +124,24 @@ implementation
const
carryflag = 1;
type
plongint = ^longint;
var
doscmd : string[128]; { Dos commandline copied from PSP, max is 128 chars }
{$ASMMODE DIRECT}
procedure halt(errnum : byte);
begin
do_exit;
flush(stderr);
asm
movzbw errnum,%ax
pushw %ax
call ___exit {frees all dpmi memory !!}
end;
end;
procedure int_stackcheck(stack_size:longint);[public,alias: 'STACKCHECK'];
{
@ -168,6 +179,28 @@ __short_on_stack:
end;
function far_strlen(selector : word;linear_address : longint) : longint;
begin
asm
movl linear_address,%edx
movl %edx,%ecx
movw selector,%gs
.Larg19:
movb %gs:(%edx),%al
testb %al,%al
je .Larg20
incl %edx
jmp .Larg19
.Larg20:
movl %edx,%eax
subl %ecx,%eax
movl %eax,__RESULT
end;
end;
{$ASMMODE ATT}
function tb : longint;
begin
tb:=go32_info_block.linear_address_of_transfer_buffer;
@ -260,25 +293,6 @@ end;
end ['ESI','EDI','ECX'];
end;
function far_strlen(selector : word;linear_address : longint) : longint;
begin
asm
movl linear_address,%edx
movl %edx,%ecx
movw selector,%gs
.Larg19:
movb %gs:(%edx),%al
testb %al,%al
je .Larg20
incl %edx
jmp .Larg19
.Larg20:
movl %edx,%eax
subl %ecx,%eax
movl %eax,__RESULT
end;
end;
function atohex(s : pchar) : longint;
var rv : longint;
@ -384,10 +398,12 @@ getmem(argv,argc shl 2);
for i := 0 to argc-1 do
argv[i] := largs[i];
tempargv:=argv;
{$ASMMODE DIRECT}
asm
movl tempargv,%eax
movl %eax,_args
end;
{$ASMMODE ATT}
end;
@ -425,10 +441,12 @@ var env_selector : word;
dos_env,cp : pchar;
stubaddr : p_stub_info;
begin
{$ASMMODE DIRECT}
asm
movl __stubinfo,%eax
movl %eax,stubaddr
end;
{$ASMMODE ATT}
stub_info:=stubaddr;
getmem(dos_env,stub_info^.env_size);
env_count:=0;
@ -489,21 +507,6 @@ end;
end;
end;
procedure halt(errnum : byte);
var regs : trealregs;
begin
do_exit;
flush(stderr);
{regs.realeax:=$4c00+errnum;
sysrealintr($21,regs);}
asm
movzbw errnum,%ax
pushw %ax
call ___exit
{call ___exit frees all dpmi memory !!}
end;
end;
function paramcount : longint;
begin
@ -535,6 +538,8 @@ end;
Heap Management
*****************************************************************************}
{$ASMMODE DIRECT}
function Sbrk(size : longint):longint;assembler;
asm
movl size,%eax
@ -543,6 +548,8 @@ asm
addl $4,%esp
end;
{$ASMMODE ATT}
{ include standard heap management }
{$I heap.inc}
@ -1006,7 +1013,11 @@ Begin
End.
{
$Log$
Revision 1.5 1998-05-21 19:30:52 peter
Revision 1.6 1998-05-31 14:18:29 peter
* force att or direct assembling
* cleanup of some files
Revision 1.5 1998/05/21 19:30:52 peter
* objects compiles for linux
+ assign(pchar), assign(char), rename(pchar), rename(char)
* fixed read_text_as_array

90
rtl/dos/graph.pp
View File

@ -5,7 +5,7 @@
members of the Free Pascal development team.
Graph unit for BP7 compatible RTL
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -95,7 +95,7 @@ procedure SetBkColor(Color : longint);
{ FILL.PPI }
procedure FloodFill(x,y:integer; Border:longint);
procedure GetFillSettings(var FillInfo : FillSettingsType);
procedure GetFillPattern(var FillPattern : FillPatternType);
procedure GetFillPattern(var FillPattern : FillPatternType);
procedure SetFillStyle(pattern : word;color : longint);
procedure SetFillPattern(pattern : FillPatternType;color : longint);
@ -128,12 +128,14 @@ function Convert(color:longint):longint;
implementation
{$ASMMODE DIRECT}
type
PString=^String;
PInteger=^integer;
PWord=^word;
PLong=^longint;
VgaInfoBlock = record
VESASignature: array[1..4]of Char;
VESAloVersion: Byte;
@ -186,19 +188,19 @@ type
OffscreenMem : word;
reserved2 : Array[1..458]of Byte;
end;
{$I MODES.PPI}
const
CheckRange : Boolean=true;
isVESA2 : Boolean=false;
core : longint=$E0000000;
var { X/Y Verhaeltnis des Bildschirm }
var { X/Y Verhaeltnis des Bildschirm }
AspectRatio : real;
XAsp , YAsp : Word;
{ Zeilen & Spalten des aktuellen Graphikmoduses }
_maxx,_maxy : longint;
_maxx,_maxy : longint;
{ aktuell eingestellte Farbe }
aktcolor : longint;
{ Hintegrundfarbe }
@ -237,20 +239,20 @@ var { X/Y Verhaeltnis des Bildschirm }
{ in diesem Puffer werden bei SetFillStyle bereits die Pattern in der }
{ zu verwendenden Farbe abgelegt }
PatternBuffer : Array[0..63]of LongInt;
X_Array : array[0..1280]of LongInt;
Y_Array : array[0..1024]of LongInt;
Sel,Seg : word;
Sel,Seg : word;
VGAInfo : VGAInfoBlock;
VESAInfo : VESAInfoBlock;
{ Selectors for Protected Mode }
seg_WRITE : word;
seg_READ : word;
seg_WRITE : word;
seg_READ : word;
{ Registers for RealModeInterrupts in DPMI-Mode }
dregs : TRealRegs;
AW_Bank : longint;
AR_Bank : Longint;
{ AR_Bank : Longint;}
{ Variables for Bankswitching }
BytesPerLine : longint;
BytesPerPixel: Word;
@ -289,7 +291,7 @@ end;
procedure Oh_Kacke(ErrString:String);
begin
CloseGraph;
CloseGraph;
writeln('Error in Unit VESA: ',ErrString);
halt;
end;
@ -301,7 +303,7 @@ procedure WaitRetrace;
begin
asm
cli
movw $0x03Da,%dx
movw $0x03Da,%dx
WaitNotHSyncLoop:
inb %dx,%al
testb $0x8,%al
@ -313,7 +315,7 @@ WaitHSyncLoop:
sti
end;
end;
procedure getmem(var p : pointer;size : longint);
begin
asm
@ -362,7 +364,7 @@ procedure graphdefaults;
aktviewport.y2:=_maxy-1;
aktscreen:=aktviewport;
{ normaler Schreibmodus }
setwritemode(normalput);
@ -372,7 +374,7 @@ procedure graphdefaults;
akttextinfo.charsize:=1;
akttextinfo.horiz:=LeftText;
akttextinfo.vert:=TopText;
{ VergrӇerungsfaktoren}
XAsp:=10000; YAsp:=10000;
aspectratio:=1;
@ -426,7 +428,7 @@ begin
end;
GetGraphMode:=GetVesaMode;
end;
procedure ClearViewport;
var bank1,bank2,diff,c:longint;
ofs1,ofs2 :longint;
@ -445,17 +447,17 @@ begin
begin
bank1:=ofs1 shr winshift;
bank2:=ofs2 shr winshift;
if bank1 <> AW_BANK then
begin
Switchbank(bank1);
if bank1 <> AW_BANK then
begin
Switchbank(bank1);
AW_BANK:=bank1;
end;
if bank1 <> bank2 then
if bank1 <> bank2 then
begin
diff:=((bank2 shl winshift)-ofs1) div BytesPerPixel;
horizontalline(aktviewport.x1, aktviewport.x1+diff-1, y);
Switchbank(bank2); AW_BANK:=bank2;
horizontalline(aktviewport.x1+diff, aktviewport.x2, y);
horizontalline(aktviewport.x1+diff, aktviewport.x2, y);
end else horizontalline(aktviewport.x1, aktviewport.x2, y);
ofs1:=ofs1 + BytesPerLine;
ofs2:=ofs2 + BytesPerLine;
@ -473,9 +475,9 @@ begin
end;
_XAsp:=XAsp; _YAsp:=YAsp;
end;
procedure SetAspectRatio(_Xasp, _Yasp : word);
begin
begin
_graphresult:=grOk;
if not isgraphmode then
begin
@ -483,8 +485,8 @@ begin
exit;
end;
Xasp:=_XAsp; YAsp:=_YAsp;
end;
end;
procedure ClearDevice;
var Viewport:ViewportType;
@ -527,12 +529,12 @@ begin
origcolor:=aktcolor;
aktlineinfo.linestyle:=solidln;
aktlineinfo.thickness:=normwidth;
case aktfillsettings.pattern of
case aktfillsettings.pattern of
0 : begin
aktcolor:=aktbackcolor;
for y:=y1 to y2 do line(x1,y,x2,y);
end;
1 : begin
1 : begin
aktcolor:=aktfillsettings.color;
for y:=y1 to y2 do line(x1,y,x2,y);
end;
@ -540,7 +542,7 @@ begin
end;
aktcolor:=origcolor;
aktlineinfo:=origlinesettings;
end;
end;
procedure bar3D(x1, y1, x2, y2 : integer;depth : word;top : boolean);
begin
@ -630,7 +632,7 @@ end;
procedure SetGraphMode(GraphMode:Integer);
var i,index:Integer;
var index:Integer;
begin
_graphresult:=grOk;
if not isgraphmode then
@ -667,16 +669,16 @@ end;
function GetMaxMode:Integer;
var i:Byte;
begin
for i:=VESANumber downto 0 do
if GetVesaInfo(VESAModes[i]) then
begin
for i:=VESANumber downto 0 do
if GetVesaInfo(VESAModes[i]) then
begin
GetMaxMode:=VESAModes[i];
Exit;
end;
end;
function GetMaxX:Integer;
begin
begin
if not isgraphmode then
begin
_graphresult:=grNoInitGraph;
@ -724,7 +726,7 @@ begin
if not isgraphmode then
begin
_graphresult:=grNoInitGraph;
exit;
exit;
end;
{ Daten <20>berpr<70>fen }
if (x1<0) or (y1<0) or (x2>=_maxx) or (y2>=_maxy) then exit;
@ -734,7 +736,7 @@ begin
aktviewport.y2:=y2;
aktviewport.clip:=clip;
end;
procedure GetViewSettings(var viewport : ViewPortType);
begin
@ -772,7 +774,7 @@ procedure SetActivePage(page : word);
exit;
end;
end;
procedure SetWriteMode(WriteMode : integer);
begin
_graphresult:=grOk;
@ -785,7 +787,7 @@ begin
begin
_graphresult:=grError;
exit;
end;
end;
aktwritemode:=writemode;
end;
@ -807,7 +809,7 @@ end;
begin
InitVESA;
if not DetectVESA then Oh_Kacke('VESA-BIOS not found...');
if not DetectVESA then Oh_Kacke('VESA-BIOS not found...');
startmode:=GetVESAMode;
bankswitchptr:=@switchbank;
GraphGetMemPtr:=@system.getmem;
@ -817,7 +819,7 @@ begin
wrbuffer:=pointer($D0000000);
rbuffer:=pointer($D0200000);
wbuffer:=pointer($D0200000);
end else begin
end else begin
wrbuffer:=pointer($0);
rbuffer:=pointer($0);
wbuffer:=pointer($0);
@ -826,7 +828,11 @@ end.
{
$Log$
Revision 1.3 1998-05-22 00:39:23 peter
Revision 1.4 1998-05-31 14:18:14 peter
* force att or direct assembling
* cleanup of some files
Revision 1.3 1998/05/22 00:39:23 peter
* go32v1, go32v2 recompiles with the new objects
* remake3 works again with go32v2
- removed some "optimizes" from daniel which were wrong