mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-05-10 02:12:32 +02:00
688 lines
16 KiB
ObjectPascal
688 lines
16 KiB
ObjectPascal
{
|
|
$Id$
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 1999-2000 by Florian Klaempfl,
|
|
member of the Free Pascal development team.
|
|
|
|
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.
|
|
|
|
**********************************************************************}
|
|
unit system;
|
|
interface
|
|
|
|
{ include system-independent routine headers }
|
|
|
|
{$I systemh.inc}
|
|
|
|
{ include heap support headers }
|
|
|
|
{$I heaph.inc}
|
|
|
|
const
|
|
{ Default filehandles }
|
|
UnusedHandle = $ffff;
|
|
StdInputHandle = 0;
|
|
StdOutputHandle = 1;
|
|
StdErrorHandle = 2;
|
|
|
|
{ Default memory segments (Tp7 compatibility) }
|
|
seg0040 = $0040;
|
|
segA000 = $A000;
|
|
segB000 = $B000;
|
|
segB800 = $B800;
|
|
|
|
var
|
|
{ C-compatible arguments and environment }
|
|
argc : longint;
|
|
argv : ppchar;
|
|
envp : ppchar;
|
|
|
|
type
|
|
{ Dos Extender info }
|
|
p_stub_info = ^t_stub_info;
|
|
t_stub_info = packed record
|
|
magic : array[0..15] of char;
|
|
size : longint;
|
|
minstack : longint;
|
|
memory_handle : longint;
|
|
initial_size : longint;
|
|
minkeep : word;
|
|
ds_selector : word;
|
|
ds_segment : word;
|
|
psp_selector : word;
|
|
cs_selector : word;
|
|
env_size : word;
|
|
basename : array[0..7] of char;
|
|
argv0 : array [0..15] of char;
|
|
dpmi_server : array [0..15] of char;
|
|
end;
|
|
|
|
t_go32_info_block = packed record
|
|
size_of_this_structure_in_bytes : longint; {offset 0}
|
|
linear_address_of_primary_screen : longint; {offset 4}
|
|
linear_address_of_secondary_screen : longint; {offset 8}
|
|
linear_address_of_transfer_buffer : longint; {offset 12}
|
|
size_of_transfer_buffer : longint; {offset 16}
|
|
pid : longint; {offset 20}
|
|
master_interrupt_controller_base : byte; {offset 24}
|
|
slave_interrupt_controller_base : byte; {offset 25}
|
|
selector_for_linear_memory : word; {offset 26}
|
|
linear_address_of_stub_info_structure : longint; {offset 28}
|
|
linear_address_of_original_psp : longint; {offset 32}
|
|
run_mode : word; {offset 36}
|
|
run_mode_info : word; {offset 38}
|
|
end;
|
|
|
|
var
|
|
stub_info : p_stub_info;
|
|
go32_info_block : t_go32_info_block;
|
|
LFNSupport : boolean;
|
|
|
|
{ Needed for CRT unit }
|
|
function do_read(h,addr,len : longint) : longint;
|
|
|
|
|
|
implementation
|
|
|
|
{ include system independent routines }
|
|
|
|
{$I system.inc}
|
|
|
|
{$ASMMODE DIRECT}
|
|
procedure int_stackcheck(stack_size:longint);[public,alias:'FPC_STACKCHECK'];
|
|
begin
|
|
{ called when trying to get local stack
|
|
if the compiler directive $S is set
|
|
this function must preserve esi !!!!
|
|
because esi is set by the calling
|
|
proc for methods
|
|
it must preserve all registers !!
|
|
With a 2048 byte safe area used to write to StdIo without crossing
|
|
the stack boundary
|
|
|
|
}
|
|
asm
|
|
pushl %eax
|
|
pushl %ebx
|
|
movl stack_size,%ebx
|
|
addl $2048,%ebx
|
|
movl %esp,%eax
|
|
subl %ebx,%eax
|
|
{$ifdef SYSTEMDEBUG}
|
|
movl U_SYSTEM_LOWESTSTACK,%ebx
|
|
cmpl %eax,%ebx
|
|
jb _is_not_lowest
|
|
movl %eax,U_SYSTEM_LOWESTSTACK
|
|
_is_not_lowest:
|
|
{$endif SYSTEMDEBUG}
|
|
movl __stkbottom,%ebx
|
|
cmpl %eax,%ebx
|
|
jae __short_on_stack
|
|
popl %ebx
|
|
popl %eax
|
|
leave
|
|
ret $4
|
|
__short_on_stack:
|
|
{ can be usefull for error recovery !! }
|
|
popl %ebx
|
|
popl %eax
|
|
end['EAX','EBX'];
|
|
HandleError(202);
|
|
end;
|
|
|
|
function paramcount : longint;
|
|
begin
|
|
paramcount := argc - 1;
|
|
end;
|
|
|
|
|
|
function paramstr(l : longint) : string;
|
|
begin
|
|
if (l>=0) and (l+1<=argc) then
|
|
paramstr:=strpas(argv[l])
|
|
else
|
|
paramstr:='';
|
|
end;
|
|
|
|
|
|
procedure randomize;
|
|
Begin
|
|
asm
|
|
movb $0x2c,%ah
|
|
int $0x21
|
|
shll $16,%ecx
|
|
movw %dx,%cx
|
|
movl %ecx,randseed
|
|
end;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
Heap Management
|
|
*****************************************************************************}
|
|
|
|
function getheapstart:pointer;assembler;
|
|
asm
|
|
leal HEAP,%eax
|
|
end ['EAX'];
|
|
|
|
|
|
function getheapsize:longint;assembler;
|
|
asm
|
|
movl HEAPSIZE,%eax
|
|
end ['EAX'];
|
|
|
|
|
|
function Sbrk(size : longint) : longint;assembler;
|
|
asm
|
|
movl size,%ebx
|
|
movl $0x4a01,%eax
|
|
int $0x21
|
|
end;
|
|
|
|
{ include standard heap management }
|
|
{$I heap.inc}
|
|
|
|
|
|
{****************************************************************************
|
|
Low Level File Routines
|
|
****************************************************************************}
|
|
|
|
procedure AllowSlash(p:pchar);
|
|
var
|
|
i : longint;
|
|
begin
|
|
{ allow slash as backslash }
|
|
for i:=0 to strlen(p) do
|
|
if p[i]='/' then p[i]:='\';
|
|
end;
|
|
|
|
|
|
procedure do_close(h : longint);assembler;
|
|
asm
|
|
movl h,%ebx
|
|
movb $0x3e,%ah
|
|
pushl %ebp
|
|
int $0x21
|
|
popl %ebp
|
|
jnc .LCLOSE1
|
|
movw %ax,inoutres
|
|
.LCLOSE1:
|
|
end;
|
|
|
|
|
|
procedure do_erase(p : pchar);
|
|
begin
|
|
AllowSlash(p);
|
|
asm
|
|
movl p,%edx
|
|
movb $0x41,%ah
|
|
pushl %ebp
|
|
int $0x21
|
|
popl %ebp
|
|
jnc .LERASE1
|
|
movw %ax,inoutres
|
|
.LERASE1:
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure do_rename(p1,p2 : pchar);
|
|
begin
|
|
AllowSlash(p1);
|
|
AllowSlash(p2);
|
|
asm
|
|
movl p1,%edx
|
|
movl p2,%edi
|
|
movb $0x56,%ah
|
|
pushl %ebp
|
|
int $0x21
|
|
popl %ebp
|
|
jnc .LRENAME1
|
|
movw %ax,inoutres
|
|
.LRENAME1:
|
|
end;
|
|
end;
|
|
|
|
|
|
function do_write(h,addr,len : longint) : longint;assembler;
|
|
asm
|
|
movl len,%ecx
|
|
movl addr,%edx
|
|
movl h,%ebx
|
|
movb $0x40,%ah
|
|
int $0x21
|
|
jnc .LDOSWRITE1
|
|
movw %ax,inoutres
|
|
xorl %eax,%eax
|
|
.LDOSWRITE1:
|
|
end;
|
|
|
|
|
|
function do_read(h,addr,len : longint) : longint;assembler;
|
|
asm
|
|
movl len,%ecx
|
|
movl addr,%edx
|
|
movl h,%ebx
|
|
movb $0x3f,%ah
|
|
int $0x21
|
|
jnc .LDOSREAD1
|
|
movw %ax,inoutres
|
|
xorl %eax,%eax
|
|
.LDOSREAD1:
|
|
end;
|
|
|
|
|
|
function do_filepos(handle : longint) : longint;assembler;
|
|
asm
|
|
movl $0x4201,%eax
|
|
movl handle,%ebx
|
|
xorl %ecx,%ecx
|
|
xorl %edx,%edx
|
|
pushl %ebp
|
|
int $0x21
|
|
popl %ebp
|
|
jnc .LDOSFILEPOS1
|
|
movw %ax,inoutres
|
|
xorl %eax,%eax
|
|
jmp .LDOSFILEPOS2
|
|
.LDOSFILEPOS1:
|
|
shll $16,%edx
|
|
movzwl %ax,%eax
|
|
orl %edx,%eax
|
|
.LDOSFILEPOS2:
|
|
end;
|
|
|
|
|
|
procedure do_seek(handle,pos : longint);assembler;
|
|
asm
|
|
movl $0x4200,%eax
|
|
movl handle,%ebx
|
|
movl pos,%edx
|
|
movl %edx,%ecx
|
|
shrl $16,%ecx
|
|
pushl %ebp
|
|
int $0x21
|
|
popl %ebp
|
|
jnc .LDOSSEEK1
|
|
movw %ax,inoutres
|
|
.LDOSSEEK1:
|
|
end;
|
|
|
|
|
|
function do_seekend(handle : longint) : longint;assembler;
|
|
asm
|
|
movl $0x4202,%eax
|
|
movl handle,%ebx
|
|
xorl %ecx,%ecx
|
|
xorl %edx,%edx
|
|
pushl %ebp
|
|
int $0x21
|
|
popl %ebp
|
|
jnc .Lset_at_end1
|
|
movw %ax,inoutres
|
|
xorl %eax,%eax
|
|
jmp .Lset_at_end2
|
|
.Lset_at_end1:
|
|
shll $16,%edx
|
|
movzwl %ax,%eax
|
|
orl %edx,%eax
|
|
.Lset_at_end2:
|
|
end;
|
|
|
|
|
|
function do_filesize(handle : longint) : longint;
|
|
var
|
|
aktfilepos : longint;
|
|
begin
|
|
aktfilepos:=do_filepos(handle);
|
|
do_filesize:=do_seekend(handle);
|
|
do_seek(handle,aktfilepos);
|
|
end;
|
|
|
|
|
|
procedure do_truncate(handle,pos : longint);assembler;
|
|
asm
|
|
movl $0x4200,%eax
|
|
movl handle,%ebx
|
|
movl pos,%edx
|
|
movl %edx,%ecx
|
|
shrl $16,%ecx
|
|
pushl %ebp
|
|
int $0x21
|
|
popl %ebp
|
|
jc .LTruncate1
|
|
movl handle,%ebx
|
|
movl %ebp,%edx
|
|
xorl %ecx,%ecx
|
|
movb $0x40,%ah
|
|
int $0x21
|
|
jnc .LTruncate2
|
|
.LTruncate1:
|
|
movw %ax,inoutres
|
|
.LTruncate2:
|
|
end;
|
|
|
|
|
|
procedure do_open(var f;p:pchar;flags:longint);
|
|
{
|
|
filerec and textrec have both handle and mode as the first items so
|
|
they could use the same routine for opening/creating.
|
|
when (flags and $100) the file will be append
|
|
when (flags and $1000) the file will be truncate/rewritten
|
|
when (flags and $10000) there is no check for close (needed for textfiles)
|
|
}
|
|
var
|
|
oflags : longint;
|
|
begin
|
|
AllowSlash(p);
|
|
{ close first if opened }
|
|
if ((flags and $10000)=0) then
|
|
begin
|
|
case filerec(f).mode of
|
|
fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
|
|
fmclosed : ;
|
|
else
|
|
begin
|
|
inoutres:=102; {not assigned}
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
{ reset file handle }
|
|
filerec(f).handle:=UnusedHandle;
|
|
oflags:=$8404;
|
|
{ convert filemode to filerec modes }
|
|
case (flags and 3) of
|
|
0 : begin
|
|
filerec(f).mode:=fminput;
|
|
oflags:=$8001;
|
|
end;
|
|
1 : filerec(f).mode:=fmoutput;
|
|
2 : filerec(f).mode:=fminout;
|
|
end;
|
|
if (flags and $1000)<>0 then
|
|
begin
|
|
filerec(f).mode:=fmoutput;
|
|
oflags:=$8302;
|
|
end
|
|
else
|
|
if (flags and $100)<>0 then
|
|
begin
|
|
filerec(f).mode:=fmoutput;
|
|
oflags:=$8404;
|
|
end;
|
|
{ empty name is special }
|
|
if p[0]=#0 then
|
|
begin
|
|
case FileRec(f).mode of
|
|
fminput :
|
|
FileRec(f).Handle:=StdInputHandle;
|
|
fminout, { this is set by rewrite }
|
|
fmoutput :
|
|
FileRec(f).Handle:=StdOutputHandle;
|
|
fmappend :
|
|
begin
|
|
FileRec(f).Handle:=StdOutputHandle;
|
|
FileRec(f).mode:=fmoutput; {fool fmappend}
|
|
end;
|
|
end;
|
|
exit;
|
|
end;
|
|
asm
|
|
movl $0xff02,%eax
|
|
movl oflags,%ecx
|
|
movl p,%ebx
|
|
int $0x21
|
|
jnc .LOPEN1
|
|
movw %ax,inoutres
|
|
movw $0xffff,%ax
|
|
.LOPEN1:
|
|
movl f,%edx
|
|
movw %ax,(%edx)
|
|
end;
|
|
if (flags and $100)<>0 then
|
|
do_seekend(filerec(f).handle);
|
|
end;
|
|
|
|
|
|
function do_isdevice(handle : longint):boolean;assembler;
|
|
asm
|
|
movl $0x4400,%eax
|
|
movl handle,%ebx
|
|
pushl %ebp
|
|
int $0x21
|
|
popl %ebp
|
|
jnc .LDOSDEVICE
|
|
movw %ax,inoutres
|
|
xorl %edx,%edx
|
|
.LDOSDEVICE:
|
|
movl %edx,%eax
|
|
shrl $7,%eax
|
|
andl $1,%eax
|
|
end;
|
|
|
|
|
|
|
|
{*****************************************************************************
|
|
UnTyped File Handling
|
|
*****************************************************************************}
|
|
|
|
{$i file.inc}
|
|
|
|
{*****************************************************************************
|
|
Typed File Handling
|
|
*****************************************************************************}
|
|
|
|
{$i typefile.inc}
|
|
|
|
{*****************************************************************************
|
|
Text File Handling
|
|
*****************************************************************************}
|
|
|
|
{$DEFINE EOF_CTRLZ}
|
|
|
|
{$i text.inc}
|
|
|
|
{*****************************************************************************
|
|
Directory Handling
|
|
*****************************************************************************}
|
|
|
|
procedure DosDir(func:byte;const s:string);
|
|
var
|
|
buffer : array[0..255] of char;
|
|
begin
|
|
move(s[1],buffer,length(s));
|
|
buffer[length(s)]:=#0;
|
|
AllowSlash(pchar(@buffer));
|
|
asm
|
|
leal buffer,%edx
|
|
movb func,%ah
|
|
int $0x21
|
|
jnc .LDOS_DIRS1
|
|
movw %ax,inoutres
|
|
.LDOS_DIRS1:
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure mkdir(const s : string);[IOCheck];
|
|
begin
|
|
If InOutRes <> 0 then exit;
|
|
DosDir($39,s);
|
|
end;
|
|
|
|
|
|
procedure rmdir(const s : string);[IOCheck];
|
|
begin
|
|
If InOutRes <> 0 then exit;
|
|
DosDir($3a,s);
|
|
end;
|
|
|
|
|
|
procedure chdir(const s : string);[IOCheck];
|
|
begin
|
|
If InOutRes <> 0 then exit;
|
|
DosDir($3b,s);
|
|
end;
|
|
|
|
|
|
procedure getdir(drivenr : byte;var dir : shortstring);
|
|
var
|
|
temp : array[0..255] of char;
|
|
sof : pchar;
|
|
i : byte;
|
|
begin
|
|
sof:=pchar(@dir[4]);
|
|
{ dir[1..3] will contain '[drivenr]:\', but is not supplied by DOS,
|
|
so we let dos string start at dir[4]
|
|
Get dir from drivenr : 0=default, 1=A etc }
|
|
asm
|
|
movb drivenr,%dl
|
|
movl sof,%esi
|
|
mov $0x47,%ah
|
|
int $0x21
|
|
end;
|
|
{ Now Dir should be filled with directory in ASCIIZ starting from dir[4] }
|
|
dir[0]:=#3;
|
|
dir[2]:=':';
|
|
dir[3]:='\';
|
|
i:=4;
|
|
{ conversation to Pascal string }
|
|
while (dir[i]<>#0) do
|
|
begin
|
|
{ convert path name to DOS }
|
|
if dir[i]='/' then
|
|
dir[i]:='\';
|
|
dir[0]:=chr(i);
|
|
inc(i);
|
|
end;
|
|
{ upcase the string }
|
|
dir:=upcase(dir);
|
|
if drivenr<>0 then { Drive was supplied. We know it }
|
|
dir[1]:=chr(65+drivenr-1)
|
|
else
|
|
begin
|
|
{ We need to get the current drive from DOS function 19H }
|
|
{ because the drive was the default, which can be unknown }
|
|
asm
|
|
movb $0x19,%ah
|
|
int $0x21
|
|
addb $65,%al
|
|
movb %al,i
|
|
end;
|
|
dir[1]:=chr(i);
|
|
end;
|
|
end;
|
|
|
|
{*****************************************************************************
|
|
System Dependent Exit code
|
|
*****************************************************************************}
|
|
Procedure system_exit;
|
|
var
|
|
err : byte;
|
|
begin
|
|
flush(stderr);
|
|
err:=exitcode and $ff;
|
|
asm
|
|
movl $0x4c00,%eax
|
|
movb err,%al
|
|
int $0x21
|
|
end;
|
|
end;
|
|
|
|
{*****************************************************************************
|
|
SystemUnit Initialization
|
|
*****************************************************************************}
|
|
|
|
Begin
|
|
{ to test stack depth }
|
|
loweststack:=maxlongint;
|
|
{ Setup heap }
|
|
InitHeap;
|
|
{ Setup stdin, stdout and stderr }
|
|
OpenStdIO(Input,fmInput,StdInputHandle);
|
|
OpenStdIO(Output,fmOutput,StdOutputHandle);
|
|
OpenStdIO(StdOut,fmOutput,StdOutputHandle);
|
|
OpenStdIO(StdErr,fmOutput,StdErrorHandle);
|
|
{ Reset IO Error }
|
|
InOutRes:=0;
|
|
End.
|
|
{
|
|
$Log$
|
|
Revision 1.10 2000-02-28 09:42:16 pierre
|
|
* system_exit instead of halt
|
|
|
|
Revision 1.9 2000/01/20 23:38:02 peter
|
|
* support fm_inout as stdoutput for assign(f,'');rewrite(f,1); becuase
|
|
rewrite opens always with filemode 2
|
|
|
|
Revision 1.8 2000/01/07 16:41:30 daniel
|
|
* copyright 2000
|
|
|
|
Revision 1.7 2000/01/07 16:32:23 daniel
|
|
* copyright 2000 added
|
|
|
|
Revision 1.6 1999/09/10 15:40:33 peter
|
|
* fixed do_open flags to be > $100, becuase filemode can be upto 255
|
|
|
|
Revision 1.5 1999/06/01 13:23:11 peter
|
|
* fixes to work with the new makefile
|
|
* os2 compiles now correct under linux
|
|
|
|
Revision 1.4 1999/04/08 12:22:57 peter
|
|
* removed os.inc
|
|
|
|
Revision 1.3 1999/01/18 10:05:49 pierre
|
|
+ system_exit procedure added
|
|
|
|
Revision 1.2 1998/12/28 15:50:44 peter
|
|
+ stdout, which is needed when you write something in the system unit
|
|
to the screen. Like the runtime error
|
|
|
|
Revision 1.1 1998/12/21 13:07:02 peter
|
|
* use -FE
|
|
|
|
Revision 1.12 1998/12/15 22:42:51 peter
|
|
* removed temp symbols
|
|
|
|
Revision 1.11 1998/11/29 22:28:09 peter
|
|
+ io-error 103 added
|
|
|
|
Revision 1.10 1998/11/16 14:15:01 pierre
|
|
* changed getdir(byte,string) to getdir(byte,shortstring)
|
|
|
|
Revision 1.9 1998/09/14 10:48:03 peter
|
|
* FPC_ names
|
|
* Heap manager is now system independent
|
|
|
|
Revision 1.8 1998/07/30 13:28:33 michael
|
|
+ Added support for errorproc. Changed runerror to HandleError
|
|
|
|
Revision 1.7 1998/07/07 12:30:20 carl
|
|
* 2k buffer for stack shecking to permimt correct io
|
|
|
|
Revision 1.6 1998/07/02 12:26:55 carl
|
|
* do_open was WRONG! Fixed!
|
|
* do_isdevice small fix with ATT parser
|
|
* I386_ATT put back , otherwise would NOT link!
|
|
* IoCheck for rmdir,chdir,mkdir
|
|
|
|
Revision 1.5 1998/07/01 15:29:56 peter
|
|
* better readln/writeln
|
|
|
|
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
|
|
|
|
} |