paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-06-03 03:38:37 +02:00
Code Issues Packages Projects Releases Wiki Activity
3c0657acf2
fpc/rtl/dos/go32v2/system.pp
pierre 3c0657acf2 + all debug in ifdef SYSTEMDEBUG 
+ added local arrays :
    opennames names of opened files
    fileopen boolean array to know if still open
    usefull with gdb if you get problems about too
    many open files !!
1998-06-26 08:19:08 +00:00

1081 lines
25 KiB
ObjectPascal
Raw Blame History

{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1993,97 by 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.
**********************************************************************}
{ no stack check in system }
{$S-}
unit system;
{$I os.inc}
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
{ Mem[] support }
mem : array[0..$7fffffff] of byte absolute $0;
memw : array[0..$7fffffff] of word absolute $0;
meml : array[0..$7fffffff] of longint absolute $0;
{ C-compatible arguments and environment }
argc : longint;
argv : ppchar;
envp : ppchar;
dos_argv0 : pchar;
{$ifndef RTLLITE}
{ System info }
Win95 : boolean;
{$endif RTLLITE}
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;
p_go32_info_block = ^t_go32_info_block;
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;
{
necessary for objects.pas, should be removed (at least from the interface
to the implementation)
}
type
trealregs=record
realedi,realesi,realebp,realres,
realebx,realedx,realecx,realeax : longint;
realflags,
reales,realds,realfs,realgs,
realip,realcs,realsp,realss : word;
end;
function do_write(h,addr,len : longint) : longint;
function do_read(h,addr,len : longint) : longint;
procedure syscopyfromdos(addr : longint; len : longint);
procedure syscopytodos(addr : longint; len : longint);
procedure sysrealintr(intnr : word;var regs : trealregs);
function tb : longint;
implementation
{ include system independent routines }
{$I system.inc}
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'];
{
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 !!
}
begin
asm
pushl %eax
pushl %ebx
movl stack_size,%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'];
RunError(202);
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;
end;
function tb_size : longint;
begin
tb_size:=go32_info_block.size_of_transfer_buffer;
end;
function dos_selector : word;
begin
dos_selector:=go32_info_block.selector_for_linear_memory;
end;
function get_ds : word;assembler;
asm
movw %ds,%ax
end;
procedure sysseg_move(sseg : word;source : longint;dseg : word;dest : longint;count : longint);
begin
if count=0 then
exit;
if (sseg<>dseg) or ((sseg=dseg) and (source>dest)) then
asm
pushw %es
pushw %ds
cld
movl count,%ecx
movl source,%esi
movl dest,%edi
movw dseg,%ax
movw %ax,%es
movw sseg,%ax
movw %ax,%ds
movl %ecx,%eax
shrl $2,%ecx
rep
movsl
movl %eax,%ecx
andl $3,%ecx
rep
movsb
popw %ds
popw %es
end ['ESI','EDI','ECX','EAX']
else if (source<dest) then
{ copy backward for overlapping }
asm
pushw %es
pushw %ds
std
movl count,%ecx
movl source,%esi
movl dest,%edi
movw dseg,%ax
movw %ax,%es
movw sseg,%ax
movw %ax,%ds
addl %ecx,%esi
addl %ecx,%edi
movl %ecx,%eax
andl $3,%ecx
orl %ecx,%ecx
jz .LSEG_MOVE1
{ calculate esi and edi}
decl %esi
decl %edi
rep
movsb
incl %esi
incl %edi
.LSEG_MOVE1:
subl $4,%esi
subl $4,%edi
movl %eax,%ecx
shrl $2,%ecx
rep
movsl
cld
popw %ds
popw %es
end ['ESI','EDI','ECX'];
end;
function atohex(s : pchar) : longint;
var rv : longint;
v : byte;
begin
rv := 0;
while (s^ <>#0) do
begin
v := byte(s^) - byte('0');
if (v > 9) then v := v - 7;
v := v and 15; { in case it's lower case }
rv := rv*16 + v;
inc(longint(s));
end;
atohex := rv;
end;
procedure setup_arguments;
type arrayword = array [0..0] of word;
var psp : word;
i,j : byte;
quote : char;
proxy_s : string[7];
tempargv : ppchar;
al,proxy_argc,proxy_seg,proxy_ofs,lin : longint;
largs : array[0..127] of pchar;
rm_argv : ^arrayword;
begin
for i := 1 to 127 do
largs[i] := nil;
psp:=stub_info^.psp_selector;
largs[0]:=dos_argv0;
argc := 1;
sysseg_move(psp, 128, get_ds, longint(@doscmd), 128);
{$IfDef SYSTEMDEBUG}
Writeln('Dos command line is #',doscmd,'# size = ',length(doscmd));
{$EndIf SYSTEMDEBUG}
j := 1;
quote := #0;
for i:=1 to length(doscmd) do
Begin
if doscmd[i] = quote then
begin
quote := #0;
doscmd[i] := #0;
largs[argc]:=@doscmd[j];
inc(argc);
j := i+1;
end else
if (quote = #0) and ((doscmd[i] = '''') or (doscmd[i]='"')) then
begin
quote := doscmd[i];
j := i + 1;
end else
if (quote = #0) and ((doscmd[i] = ' ')
or (doscmd[i] = #9) or (doscmd[i] = #10) or
(doscmd[i] = #12) or (doscmd[i] = #9)) then
begin
doscmd[i]:=#0;
if j<i then
begin
largs[argc]:=@doscmd[j];
inc(argc);
j := i+1;
end else inc(j);
end else
if (i = length(doscmd)) then
begin
doscmd[i+1]:=#0;
largs[argc]:=@doscmd[j];
inc(argc);
end;
end;
if (argc > 1) and (far_strlen(get_ds,longint(largs[1])) = 6) then
begin
move(largs[1]^,proxy_s[1],6);
proxy_s[0] := #6;
if (proxy_s = '!proxy') then
begin
{$IfDef SYSTEMDEBUG}
Writeln('proxy command line ');
{$EndIf SYSTEMDEBUG}
proxy_argc := atohex(largs[2]);
proxy_seg := atohex(largs[3]);
proxy_ofs := atohex(largs[4]);
getmem(rm_argv,proxy_argc*sizeof(word));
sysseg_move(dos_selector,proxy_seg*16+proxy_ofs, get_ds,longint(rm_argv),proxy_argc*sizeof(word));
for i:=0 to proxy_argc - 1 do
begin
lin := proxy_seg*16 + rm_argv^[i];
al :=far_strlen(dos_selector, lin);
getmem(largs[i],al+1);
sysseg_move(dos_selector, lin, get_ds,longint(largs[i]), al+1);
{$IfDef SYSTEMDEBUG}
Writeln('arg ',i,' #',largs[i],'#');
{$EndIf SYSTEMDEBUG}
end;
argc := proxy_argc;
end;
end;
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;
function strcopy(dest,source : pchar) : pchar;
begin
asm
cld
movl 12(%ebp),%edi
movl $0xffffffff,%ecx
xorb %al,%al
repne
scasb
not %ecx
movl 8(%ebp),%edi
movl 12(%ebp),%esi
movl %ecx,%eax
shrl $2,%ecx
rep
movsl
movl %eax,%ecx
andl $3,%ecx
rep
movsb
movl 8(%ebp),%eax
leave
ret $8
end;
end;
procedure setup_environment;
var env_selector : word;
env_count : longint;
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;
sysseg_move(stub_info^.psp_selector,$2c, get_ds, longint(@env_selector), 2);
sysseg_move(env_selector, 0, get_ds, longint(dos_env), stub_info^.env_size);
cp:=dos_env;
while cp ^ <> #0 do
begin
inc(env_count);
while (cp^ <> #0) do inc(longint(cp)); { skip to NUL }
inc(longint(cp)); { skip to next character }
end;
getmem(envp,(env_count+1) * sizeof(pchar));
if (envp = nil) then exit;
cp:=dos_env;
env_count:=0;
while cp^ <> #0 do
begin
getmem(envp[env_count],strlen(cp)+1);
strcopy(envp[env_count], cp);
{$IfDef SYSTEMDEBUG}
Writeln('env ',env_count,' = "',envp[env_count],'"');
{$EndIf SYSTEMDEBUG}
inc(env_count);
while (cp^ <> #0) do inc(longint(cp)); { skip to NUL }
inc(longint(cp)); { skip to next character }
end;
envp[env_count]:=nil;
longint(cp):=longint(cp)+3;
getmem(dos_argv0,strlen(cp)+1);
if (dos_argv0 = nil) then halt;
strcopy(dos_argv0, cp);
end;
procedure syscopytodos(addr : longint; len : longint);
begin
if len > tb_size then runerror(217);
sysseg_move(get_ds,addr,dos_selector,tb,len);
end;
procedure syscopyfromdos(addr : longint; len : longint);
begin
if len > tb_size then runerror(217);
sysseg_move(dos_selector,tb,get_ds,addr,len);
end;
procedure sysrealintr(intnr : word;var regs : trealregs);
begin
regs.realsp:=0;
regs.realss:=0;
asm
movw intnr,%bx
xorl %ecx,%ecx
movl regs,%edi
movw $0x300,%ax
int $0x31
end;
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;
var
hl : longint;
regs : trealregs;
begin
regs.realeax:=$2c00;
sysrealintr($21,regs);
hl:=regs.realedx and $ffff;
randseed:=hl*$10000+ (regs.realecx and $ffff);
end;
{*****************************************************************************
Heap Management
*****************************************************************************}
{$ASMMODE DIRECT}
function Sbrk(size : longint):longint;assembler;
asm
movl size,%eax
pushl %eax
call ___sbrk
addl $4,%esp
end;
{$ASMMODE ATT}
{ 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;
{$ifdef SYSTEMDEBUG}
{ Keep Track of open files }
const
max_files = 50;
var
opennames : array [0..max_files-1] of pchar;
openfiles : array [0..max_files-1] of boolean;
{$endif SYSTEMDEBUG}
procedure do_close(handle : longint);
var
regs : trealregs;
begin
regs.realebx:=handle;
{$ifdef SYSTEMDEBUG}
if handle<max_files then
openfiles[handle]:=false;
{$endif SYSTEMDEBUG}
regs.realeax:=$3e00;
sysrealintr($21,regs);
end;
procedure do_erase(p : pchar);
var
regs : trealregs;
begin
AllowSlash(p);
syscopytodos(longint(p),strlen(p)+1);
regs.realedx:=tb and 15;
regs.realds:=tb shr 4;
{$ifndef RTLLITE}
if Win95 then
regs.realeax:=$7141
else
{$endif RTLLITE}
regs.realeax:=$4100;
regs.realesi:=0;
regs.realecx:=0;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
InOutRes:=lo(regs.realeax);
end;
procedure do_rename(p1,p2 : pchar);
var
regs : trealregs;
begin
AllowSlash(p1);
AllowSlash(p2);
if strlen(p1)+strlen(p2)+3>tb_size then
RunError(217);
sysseg_move(get_ds,longint(p2),dos_selector,tb,strlen(p2)+1);
sysseg_move(get_ds,longint(p1),dos_selector,tb+strlen(p2)+2,strlen(p1)+1);
regs.realedi:=tb and 15;
regs.realedx:=tb and 15 + strlen(p2)+2;
regs.realds:=tb shr 4;
regs.reales:=regs.realds;
{$ifndef RTLLITE}
if Win95 then
regs.realeax:=$7156
else
{$endif RTLLITE}
regs.realeax:=$5600;
regs.realecx:=$ff; { attribute problem here ! }
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
InOutRes:=lo(regs.realeax);
end;
function do_write(h,addr,len : longint) : longint;
var
regs : trealregs;
size,
writesize : longint;
begin
writesize:=0;
while len > 0 do
begin
if len>tb_size then
size:=tb_size
else
size:=len;
syscopytodos(addr+writesize,size);
regs.realecx:=size;
regs.realedx:=tb and 15;
regs.realds:=tb shr 4;
regs.realebx:=h;
regs.realeax:=$4000;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
begin
InOutRes:=lo(regs.realeax);
exit(writesize);
end;
len:=len-size;
writesize:=writesize+size;
end;
Do_Write:=WriteSize
end;
function do_read(h,addr,len : longint) : longint;
var
regs : trealregs;
size,
readsize : longint;
begin
readsize:=0;
while len > 0 do
begin
if len>tb_size then
size:=tb_size
else
size:=len;
regs.realecx:=size;
regs.realedx:=tb and 15;
regs.realds:=tb shr 4;
regs.realebx:=h;
regs.realeax:=$3f00;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
begin
InOutRes:=lo(regs.realeax);
do_read:=0;
exit;
end
else
if regs.realeax<size then
begin
syscopyfromdos(addr+readsize,regs.realeax);
do_read:=readsize+regs.realeax;
exit;
end;
syscopyfromdos(addr+readsize,regs.realeax);
readsize:=readsize+regs.realeax;
len:=len-regs.realeax;
end;
do_read:=readsize;
end;
function do_filepos(handle : longint) : longint;
var
regs : trealregs;
begin
regs.realebx:=handle;
regs.realecx:=0;
regs.realedx:=0;
regs.realeax:=$4201;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
Begin
InOutRes:=lo(regs.realeax);
do_filepos:=0;
end
else
do_filepos:=lo(regs.realedx) shl 16+lo(regs.realeax);
end;
procedure do_seek(handle,pos : longint);
var
regs : trealregs;
begin
regs.realebx:=handle;
regs.realecx:=pos shr 16;
regs.realedx:=pos and $ffff;
regs.realeax:=$4200;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
InOutRes:=lo(regs.realeax);
end;
function do_seekend(handle:longint):longint;
var
regs : trealregs;
begin
regs.realebx:=handle;
regs.realecx:=0;
regs.realedx:=0;
regs.realeax:=$4202;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
Begin
InOutRes:=lo(regs.realeax);
do_seekend:=0;
end
else
do_seekend:=lo(regs.realedx) shl 16+lo(regs.realeax);
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;
{ truncate at a given position }
procedure do_truncate (handle,pos:longint);
var
regs : trealregs;
begin
do_seek(handle,pos);
regs.realecx:=0;
regs.realedx:=tb and 15;
regs.realds:=tb shr 4;
regs.realebx:=handle;
regs.realeax:=$4000;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
InOutRes:=lo(regs.realeax);
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 $10) the file will be append
when (flags and $100) the file will be truncate/rewritten
when (flags and $1000) there is no check for close (needed for textfiles)
}
var
regs : trealregs;
action : longint;
begin
AllowSlash(p);
{ close first if opened }
if ((flags and $1000)=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;
action:=$1;
{ convert filemode to filerec modes }
case (flags and 3) of
0 : filerec(f).mode:=fminput;
1 : filerec(f).mode:=fmoutput;
2 : filerec(f).mode:=fminout;
end;
if (flags and $100)<>0 then
begin
filerec(f).mode:=fmoutput;
action:=$12; {create file function}
end;
{ empty name is special }
if p[0]=#0 then
begin
case filerec(f).mode of
fminput : filerec(f).handle:=StdInputHandle;
fmappend,
fmoutput : begin
filerec(f).handle:=StdOutputHandle;
filerec(f).mode:=fmoutput; {fool fmappend}
end;
end;
exit;
end;
{ real dos call }
syscopytodos(longint(p),strlen(p)+1);
{$ifndef RTLLITE}
if Win95 then
regs.realeax:=$716c
else
{$endif RTLLITE}
regs.realeax:=$6c00;
regs.realedx:=action;
regs.realds:=tb shr 4;
regs.realesi:=tb and 15;
regs.realebx:=$2000+(flags and $ff);
regs.realecx:=$20;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
begin
InOutRes:=lo(regs.realeax);
exit;
end
else
filerec(f).handle:=regs.realeax;
{$ifdef SYSTEMDEBUG}
if regs.realeax<max_files then
begin
openfiles[regs.realeax]:=true;
getmem(opennames[regs.realeax],strlen(p)+1);
opennames[regs.realeax]:=p;
end;
{$endif SYSTEMDEBUG}
{ append mode }
if (flags and $10)<>0 then
begin
do_seekend(filerec(f).handle);
filerec(f).mode:=fmoutput; {fool fmappend}
end;
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;
regs : trealregs;
begin
move(s[1],buffer,length(s));
buffer[length(s)]:=#0;
AllowSlash(pchar(@buffer));
syscopytodos(longint(@buffer),length(s)+1);
regs.realedx:=tb and 15;
regs.realds:=tb shr 4;
{$ifndef RTLLITE}
if Win95 then
regs.realeax:=$7100+func
else
{$endif RTLLITE}
regs.realeax:=func shl 8;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
InOutRes:=lo(regs.realeax);
end;
procedure mkdir(const s : string);
begin
DosDir($39,s);
end;
procedure rmdir(const s : string);
begin
DosDir($3a,s);
end;
procedure chdir(const s : string);
begin
DosDir($3b,s);
end;
procedure getdir(drivenr : byte;var dir : string);
var
temp : array[0..255] of char;
i : longint;
regs : trealregs;
begin
regs.realedx:=drivenr;
regs.realesi:=tb and 15;
regs.realds:=tb shr 4;
{$ifndef RTLLITE}
if Win95 then
regs.realeax:=$7147
else
{$endif RTLLITE}
regs.realeax:=$4700;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
Begin
InOutRes:=lo(regs.realeax);
exit;
end
else
syscopyfromdos(longint(@temp),251);
{ conversation to Pascal string including slash conversion }
i:=0;
while (temp[i]<>#0) do
begin
if temp[i]='/' then
temp[i]:='\';
dir[i+4]:=temp[i];
inc(i);
end;
dir[2]:=':';
dir[3]:='\';
dir[0]:=char(i+3);
{ upcase the string }
dir:=upcase(dir);
if drivenr<>0 then { Drive was supplied. We know it }
dir[1]:=char(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 }
regs.realeax:=$1900;
sysrealintr($21,regs);
i:= (regs.realeax and $ff) + ord('A');
dir[1]:=chr(i);
end;
end;
{*****************************************************************************
SystemUnit Initialization
*****************************************************************************}
{$ifndef RTLLITE}
function CheckWin95:boolean;
var
regs : TRealRegs;
begin
regs.realeax:=$160a;
sysrealintr($2f,regs);
CheckWin95:=(regs.realeax=0) and ((regs.realebx and $ff00)=$400);
end;
{$endif RTLLITE}
procedure OpenStdIO(var f:text;mode:word;hdl:longint);
begin
Assign(f,'');
TextRec(f).Handle:=hdl;
TextRec(f).Mode:=mode;
TextRec(f).InOutFunc:=@FileInOutFunc;
TextRec(f).FlushFunc:=@FileInOutFunc;
TextRec(f).Closefunc:=@fileclosefunc;
end;
Begin
{ Initialize ExitProc }
ExitProc:=Nil;
{ to test stack depth }
loweststack:=maxlongint;
{ Setup heap }
InitHeap;
{ Setup stdin, stdout and stderr }
OpenStdIO(Input,fmInput,StdInputHandle);
OpenStdIO(Output,fmOutput,StdOutputHandle);
OpenStdIO(StdErr,fmOutput,StdErrorHandle);
{ Setup environment and arguments }
Setup_Environment;
Setup_Arguments;
{ Use Win95 LFN }
Win95:=CheckWin95;
{ Reset IO Error }
InOutRes:=0;
End.
{
$Log$
Revision 1.8 1998-06-26 08:19:10 pierre
+ all debug in ifdef SYSTEMDEBUG
+ added local arrays :
opennames names of opened files
fileopen boolean array to know if still open
usefull with gdb if you get problems about too
many open files !!
Revision 1.7 1998/06/15 15:17:08 daniel
* RTLLITE conditional added to produce smaller RTL.
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
+ read_text_as_pchar which was not yet in the rtl
Revision 1.4 1998/05/04 17:58:41 peter
* fix for smartlinking with _ARGS
Revision 1.3 1998/05/04 16:21:54 florian
+ win95 flag to the interface moved
}
Reference in New Issue View Git Blame Copy Permalink