paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-01 21:06:02 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ add initial RTL for MSX DOS. Simple programs are already working, but there are apparantly some code generation problems that lead to I/O as well as parameters not working correctly

Browse Source 
git-svn-id: trunk@45600 -
This commit is contained in:
svenbarth 2020-06-06 17:16:45 +00:00
parent e2d8f7b68f
commit ac8552afc2
12 changed files with 1733 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
.gitattributes vendored
View File

@ -11353,6 +11353,16 @@ rtl/msdos/sysosh.inc svneol=native#text/plain
rtl/msdos/system.pp svneol=native#text/plain
rtl/msdos/sysutils.pp svneol=native#text/plain
rtl/msdos/tthread.inc svneol=native#text/plain
rtl/msxdos/Makefile.fpc svneol=native#text/plain
rtl/msxdos/registers.inc svneol=native#text/plain
rtl/msxdos/rtldefs.inc svneol=native#text/plain
rtl/msxdos/si_prc.pp svneol=native#text/pascal
rtl/msxdos/sysdir.inc svneol=native#text/plain
rtl/msxdos/sysfile.inc svneol=native#text/plain
rtl/msxdos/sysheap.inc svneol=native#text/plain
rtl/msxdos/sysos.inc svneol=native#text/plain
rtl/msxdos/sysosh.inc svneol=native#text/plain
rtl/msxdos/system.pp svneol=native#text/pascal
rtl/nativent/Makefile svneol=native#text/plain
rtl/nativent/Makefile.fpc svneol=native#text/plain
rtl/nativent/buildrtl.lpi svneol=native#text/plain

1
rtl/Makefile.fpc
View File

@ -52,6 +52,7 @@ dirs_win16=win16
dirs_watcom=watcom
dirs_freertos=freertos
dirs_zxspectrum=zxspectrum
dirs_msxdos=msxdos
[install]
fpcpackage=y

226
rtl/msxdos/Makefile.fpc Normal file
View File

@ -0,0 +1,226 @@
#
# Makefile.fpc for MSDOS RTL
#
[package]
main=rtl
[target]
#loaders=prt0s prt0t prt0m prt0c prt0l prt0h # exceptn fpu
units=system si_prc uuchar objpas iso7185
#uuchar objpas strings dos heaptrc lnfodwrf sysconst sysutils \
# math macpas iso7185 extpas rtlconsts typinfo cpu types \
# getopts sortbase fgl classes \
# msmouse ports \
# charset cpall ctypes \
# fpwidestring character unicodedata unicodenumtable
# cmem
# initc profile dxetype dxeload emu387 \
# cpu mmx \
# vesamode \
# rsts=math typinfo classes dateutil sysconst
implicitunits=exeinfo \
cp1250 cp1251 cp1252 cp1253 cp1254 cp1255 cp1256 cp1257 cp1258 \
cp437 cp646 cp737 cp775 cp850 cp852 cp855 cp856 cp857 cp860 cp861 cp862 \
cp863 cp864 cp865 cp866 cp869 cp874 cp3021 cp8859_1 cp8859_2 cp8859_3 cp8859_4 \
cp8859_5 cp8859_6 cp8859_7 cp8859_8 cp8859_9 cp8859_10 cp8859_11 \
cp8859_13 cp8859_14 cp8859_15 cp8859_16 cpkoi8_r cpkoi8_u
[require]
nortl=y
[install]
fpcpackage=y
[default]
fpcdir=../..
target=msxdos
cpu=z80
[compiler]
includedir=$(INC) $(PROCINC)
sourcedir=$(INC) $(PROCINC) $(COMMON)
[prerules]
RTL=..
INC=../inc
COMMON=$(RTL)/common
PROCINC=../$(CPU_TARGET)
UNITPREFIX=rtl
SYSTEMUNIT=system
# Paths
OBJPASDIR=$(RTL)/objpas
# Insert exception handler in system unit
ifdef EXCEPTIONS_IN_SYSTEM
override FPCOPT+=-dEXCEPTIONS_IN_SYSTEM
endif
# Insert exception handler in system unit
ifdef NO_EXCEPTIONS_IN_SYSTEM
override FPCOPT+=-dNO_EXCEPTIONS_IN_SYSTEM
endif
[rules]
# Get the system independent include file names.
# This will set the following variables :
# SYSINCNAMES
include $(INC)/makefile.inc
SYSINCDEPS=$(addprefix $(INC)/,$(SYSINCNAMES))
# Get the processor dependent include file names.
# This will set the following variables :
# CPUINCNAMES
include $(PROCINC)/makefile.cpu
SYSCPUDEPS=$(addprefix $(PROCINC)/,$(CPUINCNAMES))
# Put system unit dependencies together.
SYSDEPS=$(SYSINCDEPS) $(SYSCPUDEPS)
#
# Loaders
#
ifneq ($(findstring -dTEST_I8086_SMARTLINK_SECTIONS,$(FPCOPT)),)
override NASM_OPT+=-D__I8086_SMARTLINK_SECTIONS__
endif
#
# System Units (System, Objpas, Strings)
#
system$(PPUEXT) : system.pp $(SYSDEPS) $(INC)/tnyheaph.inc $(INC)/tinyheap.inc registers.inc
$(COMPILER) $(FPC_SYSTEM_OPT) -Us -Sg system.pp
$(EXECPPAS)
uuchar$(PPUEXT): $(SYSTEMUNIT)$(PPUEXT) $(INC)/uuchar.pp
$(COMPILER) $(INC)/uuchar.pp
$(EXECPPAS)
objpas$(PPUEXT): $(OBJPASDIR)/objpas.pp $(INC)/except.inc system$(PPUEXT)
$(COMPILER) -Fi$(OBJPASDIR) $(OBJPASDIR)/objpas.pp
$(EXECPPAS)
strings$(PPUEXT) : $(INC)/strings.pp $(INC)/stringsi.inc \
$(PROCINC)/strings.inc $(PROCINC)/stringss.inc \
$(INC)/genstr.inc $(INC)/genstrs.inc \
system$(PPUEXT)
$(COMPILER) $(INC)/strings.pp
$(EXECPPAS)
iso7185$(PPUEXT) : $(INC)/iso7185.pp system$(PPUEXT)
$(COMPILER) $(INC)/iso7185.pp
$(EXECPPAS)
extpas$(PPUEXT) : $(INC)/extpas.pp dos$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
$(COMPILER) $(INC)/extpas.pp
$(EXECPPAS)
#
# System Dependent Units
#
ports$(PPUEXT) : ports.pp system$(PPUEXT)
$(COMPILER) ports.pp
$(EXECPPAS)
#
# TP7 Compatible RTL Units
#
dos$(PPUEXT) : dos.pp registers.inc \
$(INC)/dosh.inc $(INC)/dos.inc $(INC)/fexpand.inc \
strings$(PPUEXT) system$(PPUEXT)
$(COMPILER) dos.pp
$(EXECPPAS)
#
# Delphi Compatible Units
#
sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/sysutils/*.inc) \
objpas$(PPUEXT) dos$(PPUEXT) sysconst$(PPUEXT) system$(PPUEXT)
$(COMPILER) -Fi$(OBJPASDIR)/sysutils sysutils.pp
$(EXECPPAS)
classes$(PPUEXT) : classes.pp $(wildcard $(OBJPASDIR)/classes/*.inc) \
sysutils$(PPUEXT) typinfo$(PPUEXT) rtlconsts$(PPUEXT) \
types$(PPUEXT) fgl$(PPUEXT) sortbase$(PPUEXT) \
objpas$(PPUEXT) system$(PPUEXT)
$(COMPILER) -Fi$(OBJPASDIR)/classes classes.pp
$(EXECPPAS)
fgl$(PPUEXT) : $(OBJPASDIR)/fgl.pp types$(PPUEXT) sysutils$(PPUEXT) rtlconsts$(PPUEXT) objpas$(PPUEXT) system$(PPUEXT) sortbase$(PPUEXT)
$(COMPILER) $(OBJPASDIR)/fgl.pp
$(EXECPPAS)
math$(PPUEXT): $(OBJPASDIR)/math.pp $(PROCINC)/mathu.inc objpas$(PPUEXT) sysutils$(PPUEXT) system$(PPUEXT)
$(COMPILER) $(OBJPASDIR)/math.pp
$(EXECPPAS)
typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp sysutils$(PPUEXT) objpas$(PPUEXT) rtlconsts$(PPUEXT) system$(PPUEXT)
$(COMPILER) -Sg -Fi$(OBJPASDIR) $(OBJPASDIR)/typinfo.pp
$(EXECPPAS)
types$(PPUEXT) : $(OBJPASDIR)/types.pp objpas$(PPUEXT) math$(PPUEXT) system$(PPUEXT)
$(COMPILER) $(OBJPASDIR)/types.pp
$(EXECPPAS)
rtlconsts$(PPUEXT) : $(OBJPASDIR)/rtlconsts.pp $(OBJPASDIR)/rtlconst.inc objpas$(PPUEXT) system$(PPUEXT)
$(COMPILER) -Fi$(OBJPASDIR) $(OBJPASDIR)/rtlconsts.pp
$(EXECPPAS)
sysconst$(PPUEXT) : $(OBJPASDIR)/sysconst.pp objpas$(PPUEXT) system$(PPUEXT)
$(COMPILER) $(OBJPASDIR)/sysconst.pp
$(EXECPPAS)
#
# Mac Pascal Model
#
macpas$(PPUEXT) : $(INC)/macpas.pp objpas$(PPUEXT) math$(PPUEXT) system$(PPUEXT)
$(COMPILER) $(INC)/macpas.pp $(REDIR)
$(EXECPPAS)
#
# Other system-independent RTL Units
#
cpu$(PPUEXT) : $(PROCINC)/cpu.pp sysutils$(PPUEXT) system$(PPUEXT)
$(COMPILER) $(PROCINC)/cpu.pp
$(EXECPPAS)
getopts$(PPUEXT) : $(INC)/getopts.pp system$(PPUEXT)
$(COMPILER) $(INC)/getopts.pp $(REDIR)
$(EXECPPAS)
heaptrc$(PPUEXT) : $(INC)/heaptrc.pp system$(PPUEXT)
$(COMPILER) -Sg $(INC)/heaptrc.pp
$(EXECPPAS)
lnfodwrf$(PPUEXT) : $(INC)/lnfodwrf.pp exeinfo$(PPUEXT) system$(PPUEXT)
$(COMPILER) $(INC)/lnfodwrf.pp
$(EXECPPAS)
exeinfo$(PPUEXT) : $(INC)/exeinfo.pp strings$(PPUEXT) system$(PPUEXT)
$(COMPILER) $(INC)/exeinfo.pp
$(EXECPPAS)
charset$(PPUEXT) : $(INC)/charset.pp objpas$(PPUEXT) system$(PPUEXT)
$(COMPILER) $(INC)/charset.pp
$(EXECPPAS)
cpall$(PPUEXT): $(RTL)/charmaps/cpall.pas system$(PPUEXT) charset$(PPUEXT)
$(COMPILER) -Fu$(INC) -Fi$(RTL)/charmaps $(RTL)/charmaps/cpall.pas
$(EXECPPAS)
fpwidestring$(PPUEXT): $(OBJPASDIR)/fpwidestring.pp unicodedata$(PPUEXT) charset$(PPUEXT) objpas$(PPUEXT) system$(PPUEXT)
$(COMPILER) $(OBJPASDIR)/fpwidestring.pp
character$(PPUEXT): $(OBJPASDIR)/character.pas sysutils$(PPUEXT) objpas$(PPUEXT) rtlconsts$(PPUEXT) unicodedata$(PPUEXT) system$(PPUEXT)
$(COMPILER) $(OBJPASDIR)/character.pas
unicodenumtable$(PPUEXT) : $(OBJPASDIR)/unicodenumtable.pas objpas$(PPUEXT) system$(PPUEXT)
$(COMPILER) -Fi$(OBJPASDIR) $(OBJPASDIR)/unicodenumtable.pas
unicodedata$(PPUEXT) : $(OBJPASDIR)/unicodedata.pas unicodenumtable$(PPUEXT) objpas$(PPUEXT) system$(PPUEXT)
$(COMPILER) -Fi$(OBJPASDIR) $(OBJPASDIR)/unicodedata.pas
sortbase$(PPUEXT) : $(INC)/sortbase.pp objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
$(COMPILER) $<
#
# Other system-dependent RTL Units
#
msmouse$(PPUEXT) : msmouse.pp system$(PPUEXT)
$(COMPILER) msmouse.pp $(REDIR)
$(EXECPPAS)
ctypes$(PPUEXT) : $(INC)/ctypes.pp system$(PPUEXT)
$(COMPILER) $(INC)/ctypes.pp $(REDIR)
$(EXECPPAS)
si_prc$(PPUEXT) : system$(PPUEXT)
$(COMPILER) si_prc.pp

10
rtl/msxdos/registers.inc Normal file
View File

@ -0,0 +1,10 @@
{ Registers record used by Intr and MsxDos. This include file is shared between
the system unit and the dos unit. }
type
Registers = packed record
case Integer of
0: (BC, DE, AF, HL, IX, IY: Word);
1: (C, B, E, D, Flags, A, L, H, IXl, IXh, IYl, IYh: Byte);
end;

24
rtl/msxdos/rtldefs.inc Normal file
View File

@ -0,0 +1,24 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2012 by Free Pascal development team
This file contains platform-specific defines that are used in
multiple RTL units.
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.
**********************************************************************}
{ the single byte OS APIs always use UTF-8 }
{ define FPCRTL_FILESYSTEM_UTF8}
{ The OS supports a single byte file system operations API that we use }
{$define FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
{ The OS supports a two byte file system operations API that we use }
{ define FPCRTL_FILESYSTEM_TWO_BYTE_API}

36
rtl/msxdos/si_prc.pp Normal file
View File

@ -0,0 +1,36 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2020 by Free Pascal development team
This file contains startup code for the ZX Spectrum
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 si_prc;
{$SMARTLINK OFF}
interface
implementation
var
stktop: word; external name '__stktop';
procedure PascalMain; external name 'PASCALMAIN';
{ this *must* always remain the first procedure with code in this unit }
procedure _start; assembler; nostackframe; public name 'start';
asm
ld (stktop), sp
jp PASCALMAIN
end;
end.

153
rtl/msxdos/sysdir.inc Normal file
View File

@ -0,0 +1,153 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by Florian Klaempfl and Pavel Ozerski
member of the Free Pascal development team.
FPC Pascal system unit for the Win32 API.
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.
**********************************************************************}
{*****************************************************************************
Directory Handling
*****************************************************************************}
{$ifdef todo}
procedure DosDir(func:byte;s: rawbytestring);
var
regs : Registers;
len : Integer;
begin
DoDirSeparators(s);
{ True DOS does not like backslashes at end
Win95 DOS accepts this !!
but "\" and "c:\" should still be kept and accepted hopefully PM }
len:=length(s);
if (len>0) and (s[len]='\') and
Not ((len=1) or ((len=3) and (s[2]=':'))) then
s[len]:=#0;
regs.DX:=Ofs(s[1]);
regs.DS:=Seg(s[1]);
if LFNSupport then
regs.AX:=$7100+func
else
regs.AX:=func shl 8;
MsDos(regs);
if (regs.Flags and fCarry) <> 0 then
GetInOutRes(regs.AX);
end;
{$endif}
Procedure do_MkDir(const s: rawbytestring);
begin
GetInOutRes(153);
//DosDir($39,s);
end;
Procedure do_RmDir(const s: rawbytestring);
begin
if s='.' then
begin
InOutRes:=16;
exit;
end;
GetInOutRes(153);
//DosDir($3a,s);
end;
Procedure do_ChDir(const s: rawbytestring);
{$ifdef todo}
var
regs : Registers;
len : Integer;
{$endif}
begin
GetInOutRes(153);
{$ifdef todo}
len:=Length(s);
{ First handle Drive changes }
if (len>=2) and (s[2]=':') then
begin
regs.DX:=(ord(s[1]) and (not 32))-ord('A');
regs.AX:=$0e00;
MsDos(regs);
regs.AX:=$1900;
MsDos(regs);
if regs.AL<>regs.DL then
begin
Inoutres:=15;
exit;
end;
{ DosDir($3b,'c:') give Path not found error on
pure DOS PM }
if len=2 then
exit;
end;
{ do the normal dos chdir }
DosDir($3b,s);
{$endif}
end;
procedure do_GetDir (DriveNr: byte; var Dir: RawByteString);
{$ifdef todo}
var
temp : array[0..260] of char;
i : integer;
regs : Registers;
{$endif}
begin
GetInOutRes(153);
{$ifdef todo}
regs.DX:=drivenr;
regs.SI:=Ofs(temp);
regs.DS:=Seg(temp);
if LFNSupport then
regs.AX:=$7147
else
regs.AX:=$4700;
MsDos(regs);
if (regs.Flags and fCarry) <> 0 then
Begin
GetInOutRes (regs.AX);
Dir := char (DriveNr + 64) + ':\';
SetCodePage (Dir,DefaultFileSystemCodePage,false);
exit;
end
else
temp[252] := #0; { to avoid shortstring buffer overflow }
{ conversion to Pascal string including slash conversion }
i:=0;
SetLength(dir,260);
while (temp[i]<>#0) do
begin
if temp[i] in AllowDirectorySeparators then
temp[i]:=DirectorySeparator;
dir[i+4]:=temp[i];
inc(i);
end;
dir[2]:=':';
dir[3]:='\';
SetLength(dir,i+3);
SetCodePage (dir,DefaultFileSystemCodePage,false);
{ upcase the string }
if not FileNameCasePreserving then
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.AX:=$1900;
MsDos(regs);
i:= (regs.AX and $ff) + ord('A');
dir[1]:=chr(i);
end;
{$endif}
end;

373
rtl/msxdos/sysfile.inc Normal file
View File

@ -0,0 +1,373 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2001 by Free Pascal development team
Low leve file functions
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.
**********************************************************************}
{ Keep Track of open files }
const
max_files = 50;
var
openfiles : array [0..max_files-1] of boolean;
{$ifdef SYSTEMDEBUG}
opennames : array [0..max_files-1] of pchar;
const
free_closed_names : boolean = true;
verbose_files : boolean = true;
{$endif SYSTEMDEBUG}
{****************************************************************************
Low level File Routines
****************************************************************************}
procedure do_close(handle : thandle);
var
regs: Registers;
begin
if Handle <= 4 then
exit;
regs.A := 0;
regs.B := Byte(handle);
if handle < max_files then
begin
{$ifdef SYSTEMDEBUG}
if not openfiles[handle] then
Writeln(stderr,'Trying to close file h=',handle,' marked as closed');
if assigned(opennames[handle]) and free_closed_names then
begin
if verbose_files then
Writeln(stderr,'file ',opennames[handle],' closed');
sysfreememsize(opennames[handle],strlen(opennames[handle])+1);
opennames[handle]:=nil;
end;
{$endif SYSTEMDEBUG}
openfiles[handle]:=false;
end;
regs.C := $45;
MsxDos(regs);
if regs.A <> 0 then
begin
GetInOutRes(regs.A);
{$ifdef SYSTEMDEBUG}
if verbose_files then
Writeln(stderr,'file close failed A = ',regs.A);
{$endif SYSTEMDEBUG}
end;
end;
procedure do_erase(p : pchar; pchangeable: boolean);
var
regs: Registers;
oldp: pchar;
begin
oldp := p;
DoDirSeparators(p, pchangeable);
regs.A := 0;
regs.C := $4D;
regs.DE := PtrUInt(p);
MsxDos(regs);
if regs.A <> 0 then
GetInOutRes(regs.A);
if p <> oldp then
freemem(p);
end;
procedure do_rename(p1,p2 : pchar; p1changeable, p2changeable: boolean);
var
regs: Registers;
oldp1, oldp2: pchar;
begin
oldp1 := p1;
oldp2 := p2;
DoDirSeparators(p1, p1changeable);
DoDirSeparators(p2, p2changeable);
regs.A := 0;
regs.C := $4E;
{ ToDo: check for same directory? }
regs.DE := PtrUInt(p1);
regs.HL := PtrUInt(p2);
MsxDos(regs);
if regs.A <> 0 then
GetInOutRes(regs.A);
if p1 <> oldp1 then
freemem(p1);
if p2 <> oldp2 then
freemem(p2);
end;
function do_write(h:thandle;addr:pointer;len : longint) : longint;
var
regs: Registers;
begin
regs.C := $49;
regs.A := 0;
regs.B := h;
regs.DE := PtrUInt(addr);
regs.HL := len;
MsxDos(regs);
if regs.A <> 0 then
begin
GetInOutRes(regs.A);
exit(0);
end;
do_write := regs.HL;
end;
function do_read(h:thandle;addr:pointer;len : longint) : longint;
var
regs: Registers;
begin
regs.C := $48;
regs.A := 0;
regs.B := h;
regs.DE := PtrUInt(addr);
regs.HL := len;
MsxDos(regs);
if regs.A <> 0 then
begin
GetInOutRes(regs.A);
exit(0);
end;
do_read := regs.HL;
end;
function do_filepos(handle : thandle) : longint;
var
regs : Registers;
begin
regs.C := $4A;
regs.B := handle;
regs.A := 1;
regs.DE := 0;
regs.HL := 0;
MsxDos(regs);
if regs.A <> 0 then
begin
GetInOutRes(regs.A);
do_filepos := 0;
end
else
do_filepos := (longint(regs.DE) shl 16) + regs.HL;
end;
procedure do_seek(handle:thandle;pos : longint);
var
regs: Registers;
begin
regs.C := $4A;
regs.B := handle;
regs.A := 0;
regs.DE := pos shr 16;
regs.HL := pos and $ffff;
MsxDos(regs);
if regs.A <> 0 then
GetInOutRes(regs.A);
end;
function do_seekend(handle:thandle):longint;
var
regs : Registers;
begin
regs.C := $4A;
regs.B := handle;
regs.A := 2;
regs.DE := 0;
regs.HL := 0;
MsxDos(regs);
if regs.A <> 0 then
begin
GetInOutRes(regs.A);
do_seekend := 0;
end
else
do_seekend := (longint(regs.DE) shl 16) + regs.HL;
end;
function do_filesize(handle : thandle) : 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:thandle;pos:longint);
{var
regs : Registers;}
begin
GetInOutRes(153);
{do_seek(handle,pos);
regs.C:=??;
regs.B:=handle;
MsxDos(regs);
if regs.A <> 0 then
GetInOutRes(regs.A);}
end;
procedure do_open(var f;p:pchar;flags:longint; pchangeable: boolean);
{
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
regs : Registers;
action : word;
oldp : pchar;
begin
{$ifdef SYSTEMDEBUG}
if verbose_files then
Writeln(stderr,'do_open for file "',p,'" called');
{$endif SYSTEMDEBUG}
{ 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;
action:=$1;
{ convert filemode to filerec modes }
regs.A:=0;
case (flags and 3) of
0 : begin
filerec(f).mode:=fminput;
{ b1 -> no write }
regs.A := 1;
end;
1 : begin
filerec(f).mode:=fmoutput;
{ b2 -> no read }
regs.A := 2;
end;
2 : filerec(f).mode:=fminout;
end;
if (flags and $1000)<>0 then
action:=$12; {create file function}
{ 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;
oldp:=p;
DoDirSeparators(p,pchangeable);
if (action and $00f0) <> 0 then
regs.C := $44 { Map to Create/Replace API }
else
regs.C := $43; { Map to Open_Existing API }
regs.B := 0;
MsxDos(regs);
if regs.A <> 0 then
begin
FileRec(f).mode:=fmclosed;
GetInOutRes(regs.A);
if oldp<>p then
freemem(p);
{$ifdef SYSTEMDEBUG}
if verbose_files then
Writeln(stderr,'MSXDOS INT open for file "',p,'" failed err=',regs.A);
{$endif SYSTEMDEBUG}
exit;
end
else
begin
filerec(f).handle:=regs.B;
end;
{$ifdef SYSTEMDEBUG}
if verbose_files then
Writeln(stderr,'MSXDOS INT open for file "',p,'" returned ',regs.B);
{$endif SYSTEMDEBUG}
if regs.B<max_files then
begin
{$ifdef SYSTEMDEBUG}
if openfiles[regs.B] and
assigned(opennames[regs.B]) then
begin
Writeln(stderr,'file ',opennames[regs.B],'(',regs.B,') not closed but handle reused!');
sysfreememsize(opennames[regs.B],strlen(opennames[regs.B])+1);
end;
{$endif SYSTEMDEBUG}
openfiles[regs.B]:=true;
{$ifdef SYSTEMDEBUG}
opennames[regs.B] := sysgetmem(strlen(p)+1);
move(p^,opennames[regs.B]^,strlen(p)+1);
if verbose_files then
Writeln(stderr,'file ',opennames[regs.B],' opened');
{$endif SYSTEMDEBUG}
end;
{ append mode }
if ((flags and $100) <> 0) and
(FileRec (F).Handle <> UnusedHandle) then
begin
do_seekend(filerec(f).handle);
filerec(f).mode:=fmoutput; {fool fmappend}
end;
if oldp<>p then
freemem(p);
end;
function do_isdevice(handle:THandle):boolean;
var
regs: Registers;
begin
regs.C := $4B;
regs.B := handle;
regs.A := $00;
MsxDos(regs);
do_isdevice := (regs.D and $80) <> 0;
if regs.A <> 0 then
GetInOutRes(regs.A);
end;

117
rtl/msxdos/sysheap.inc Normal file
View File

@ -0,0 +1,117 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2001 by Free Pascal development team
This file implements all the base types and limits required
for a minimal POSIX compliant subset required to port the compiler
to a new OS.
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.
**********************************************************************}
{*****************************************************************************
Heap Management
*****************************************************************************}
{$ifdef DEBUG_TINY_HEAP}
{ Internal structure used by MSDOS }
type
MCB = packed record
sig : char;
psp : word;
paragraphs : word;
res : array [0..2] of char;
exename : array [0..7] of char;
end;
PMCB = ^MCB;
{$endif def DEBUG_TINY_HEAP}
function SysOSAlloc (size: ptruint): pointer;
var
regs : Registers;
nb_para : longint;
{$ifdef DEBUG_TINY_HEAP}
p : pmcb;
i : byte;
{$endif def DEBUG_TINY_HEAP}
begin
{$ifdef DEBUG_TINY_HEAP}
writeln('SysOSAlloc called size=',size);
{$endif}
{$if defined(FPC_X86_DATA_FAR) or defined(FPC_X86_DATA_HUGE)}
regs.ax:=$4800;
nb_para:=size div 16;
if nb_para > $ffff then
begin
{$ifdef DEBUG_TINY_HEAP}
writeln('SysOSAlloc size too big = ',size);
{$endif}
result:=nil;
end
else
begin
regs.bx:=nb_para;
msdos(regs);
if (regs.Flags and fCarry) <> 0 then
begin
{$ifdef DEBUG_TINY_HEAP}
writeln('SysOSAlloc failed, err = ',regs.AX);
{$endif}
{ Do not set InOutRes if ReturnNilIfGrowHeapFails is set }
if not ReturnNilIfGrowHeapFails then
GetInOutRes(regs.AX);
Result := nil;
end
else
begin
result:=ptr(regs.ax,0);
{$ifdef DEBUG_TINY_HEAP}
writeln('SysOSAlloc returned= $',hexstr(regs.ax,4),':$0');
p:=ptr(regs.ax-1,0);
writeln('Possibly prev MCB: at ',hexstr(p));
writeln(' sig=',p^.sig);
writeln(' psp=$',hexstr(p^.psp,4));
writeln(' paragraphs=',p^.paragraphs);
if (p^.exename[0]<>#0) then
begin
write(' name=');
for i:=0 to 7 do
if ord(p^.exename[i])>31 then
write(p^.exename[i]);
writeln;
end;
p:=ptr(regs.ax+p^.paragraphs,0);
writeln('Possibly next MCB: at ',hexstr(p));
writeln(' sig=',p^.sig);
writeln(' psp=$',hexstr(p^.psp,4));
writeln(' paragraphs=',p^.paragraphs);
if (p^.exename[0]<>#0) then
begin
write(' name=');
for i:=0 to 7 do
if ord(p^.exename[i])>31 then
write(p^.exename[i]);
writeln;
end;
{$endif}
end;
end;
{$else not DATA_FAR}
{$ifdef DEBUG_TINY_HEAP}
writeln('SysOSAlloc cannot be used in small data models');
{$endif}
Result := nil;
{$endif not DATA_FAR}
end;
procedure SysOSFree(p: pointer; size: ptruint);
begin
end;

33
rtl/msxdos/sysos.inc Normal file
View File

@ -0,0 +1,33 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2013 by Free Pascal development team
This file implements all the base types and limits required
for a minimal POSIX compliant subset required to port the compiler
to a new OS.
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.
**********************************************************************}
procedure GetInOutRes(def: Word);
var
regs : Registers;
begin
regs.C:=$65;
MsxDos(regs);
InOutRes:=regs.B;
case InOutRes of
19 : InOutRes:=150;
21 : InOutRes:=152;
32 : InOutRes:=5;
end;
if InOutRes=0 then
InOutRes:=Def;
end;

28
rtl/msxdos/sysosh.inc Normal file
View File

@ -0,0 +1,28 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2013 by Free Pascal development team
This file implements all the base types and limits required
for a minimal POSIX compliant subset required to port the compiler
to a new OS.
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.
**********************************************************************}
{Platform specific information}
type
THandle = Byte;
TThreadID = THandle;
TOSTimestamp = Longint;
PRTLCriticalSection = ^TRTLCriticalSection;
TRTLCriticalSection = record
Locked: boolean
end;

722
rtl/msxdos/system.pp Normal file
View File

@ -0,0 +1,722 @@
unit System;
interface
{$define FPC_IS_SYSTEM}
{ The heap for MSDOS is implemented
in tinyheap.inc include file,
but it uses default SysGetMem names }
{$define HAS_MEMORYMANAGER}
{ define TEST_FPU_INT10 to force keeping local int10,
for testing purpose only }
{$DEFINE FPC_INCLUDE_SOFTWARE_MUL}
{$DEFINE FPC_INCLUDE_SOFTWARE_MOD_DIV}
{$DEFINE FPC_USE_SMALL_DEFAULTSTACKSIZE}
{ To avoid warnings in thread.inc code,
but value must be really given after
systemh.inc is included otherwise the
$mode switch is not effective }
{ Use Ansi Char for files }
{$define FPC_ANSI_TEXTFILEREC}
{$define FPC_STDOUT_TRUE_ALIAS}
{$ifdef NO_WIDESTRINGS}
{ Do NOT use wide Char for files }
{$undef FPC_HAS_FEATURE_WIDESTRINGS}
{$endif NO_WIDESTRINGS}
{$I systemh.inc}
{$I tnyheaph.inc}
{.$I portsh.inc}
{$ifndef FPUNONE}
{$ifdef FPC_HAS_FEATURE_SOFTFPU}
{$define fpc_softfpu_interface}
{$i softfpu.pp}
{$undef fpc_softfpu_interface}
{$endif FPC_HAS_FEATURE_SOFTFPU}
{$endif FPUNONE}
const
LineEnding = #13#10;
{ LFNSupport is a variable here, defined below!!! }
DirectorySeparator = '\';
DriveSeparator = ':';
ExtensionSeparator = '.';
PathSeparator = ';';
AllowDirectorySeparators : set of char = ['\','/'];
AllowDriveSeparators : set of char = [':'];
{ FileNameCaseSensitive and FileNameCasePreserving are defined separately below!!! }
maxExitCode = 255;
MaxPathLen = 256;
const
{ Default filehandles }
UnusedHandle = $ffff;{ instead of -1, as it is a word value}
StdInputHandle = 0;
StdOutputHandle = 1;
{ MSX-DOS does not have a separate StdErr }
StdErrorHandle = 1;
FileNameCaseSensitive : boolean = false;
FileNameCasePreserving: boolean = false;
CtrlZMarksEOF: boolean = true; (* #26 is considered as end of file *)
sLineBreak = LineEnding;
DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsCRLF;
var
{ Mem[] support }
mem : array[0..$7fff-1] of byte absolute $0;
memw : array[0..($7fff div sizeof(word))-1] of word absolute $0;
meml : array[0..($7fff div sizeof(longint))-1] of longint absolute $0;
{ C-compatible arguments and environment }
argc:smallint; //!! public name 'operatingsystem_parameter_argc';
argv:PPchar; //!! public name 'operatingsystem_parameter_argv';
{ The DOS Program Segment Prefix segment (TP7 compatibility) }
PrefixSeg:Word;public name '__fpc_PrefixSeg';
SaveInt00: FarPointer;public name '__SaveInt00';
SaveInt10: FarPointer;public name '__SaveInt10';
SaveInt75: FarPointer;public name '__SaveInt75';
fpu_status: word;public name '__fpu_status';
const
AllFilesMask: string [3] = '*.*';
const
LFNSupport = false;
implementation
procedure DebugWrite(s: PChar); forward;
procedure DebugWrite(const S: string); forward;
procedure DebugWriteLn(const S: string); forward;
{$ifdef todo}
const
{ used for an offset fixup for accessing the proc parameters in asm routines
that use nostackframe. We can't use the parameter name directly, because
i8086 doesn't support sp relative addressing. }
{$ifdef FPC_X86_CODE_FAR}
extra_param_offset = 2;
{$else FPC_X86_CODE_FAR}
extra_param_offset = 0;
{$endif FPC_X86_CODE_FAR}
{$if defined(FPC_X86_DATA_FAR) or defined(FPC_X86_DATA_HUGE)}
extra_data_offset = 2;
{$else}
extra_data_offset = 0;
{$endif}
type
PFarByte = ^Byte;//far;
PFarChar = ^Char;//far;
PFarWord = ^Word;//far;
PPFarChar = ^PFarChar;
{$endif}
var
stklen: word; external name '__stklen';
__heapsize: Word;external name '__heapsize';
__fpc_initialheap: array[0..0] of byte;external name '__fpc_initialheap';
var
__stktop : pointer;public name '__stktop';
dos_version:Word;public name 'dos_version';
dos_env_count:smallint;public name '__dos_env_count';
dos_argv0 : PChar;public name '__fpc_dos_argv0';
{$I registers.inc}
procedure Intr(IntNo: Byte; var Regs: Registers); external name 'FPC_INTR';
procedure MsxDos(var Regs: Registers); assembler; nostackframe; public name 'FPC_MSXDOS';
asm
//in a, (0x2e)
{ store registers contents }
push AF
push BC
push DE
push HL
push IX
push IY
{ allocate an additional scratch space }
push IY
{ Regs now resides at SP + 16 }
{ IY is not used for parameters, so base everything on that;
for that we need to load the address of Regs into IY }
ld IX, 0x10
add IX, SP
ld L,(IX+0)
ld H,(IX+1)
push HL
pop IY
{ fill IX with the help of HL }
ld L,(IY+8)
ld H,(IY+9)
push HL
pop IX
ld B,(IY+1)
ld C,(IY+0)
ld D,(IY+3)
ld E,(IY+2)
// load A last
//ld A,(IY+4)
ld H,(IY+7)
ld L,(IY+6)
ld A,(IY+4)
{ store IY to scratch location }
ex (SP),IY
{ call to DOS }
call 0x0005
{ store IY to scratch and restore pointer address of Regs }
ex (SP),IY
ld (IY+1),B
ld (IY+0),C
ld (IY+3),D
ld (IY+2),E
ld (IY+4),A
// skip F
ld (IY+7),H
ld (IY+6),L
{ store IX with the help of HL }
push IX
pop HL
ld (IY+8),L
ld (IY+9),H
{ store the stored IY with the help of HL }
ex (SP),HL
ld (IY+10),L
ld (IY+11),H
{ cleanup stack }
pop IY
pop IY
pop IX
pop HL
pop DE
pop BC
pop AF
end;
procedure InstallInterruptHandlers; external name 'FPC_INSTALL_INTERRUPT_HANDLERS';
procedure RestoreInterruptHandlers; external name 'FPC_RESTORE_INTERRUPT_HANDLERS';
function CheckNullArea: Boolean; external name 'FPC_CHECK_NULLAREA';
{$I system.inc}
{$I tinyheap.inc}
{.$I ports.inc}
{$ifndef FPUNONE}
{$ifdef FPC_HAS_FEATURE_SOFTFPU}
{$define fpc_softfpu_implementation}
{$i softfpu.pp}
{$undef fpc_softfpu_implementation}
{ we get these functions and types from the softfpu code }
{$define FPC_SYSTEM_HAS_float64}
{$define FPC_SYSTEM_HAS_float32}
{$define FPC_SYSTEM_HAS_flag}
{$define FPC_SYSTEM_HAS_extractFloat64Frac0}
{$define FPC_SYSTEM_HAS_extractFloat64Frac1}
{$define FPC_SYSTEM_HAS_extractFloat64Exp}
{$define FPC_SYSTEM_HAS_extractFloat64Frac}
{$define FPC_SYSTEM_HAS_extractFloat64Sign}
{$define FPC_SYSTEM_HAS_ExtractFloat32Frac}
{$define FPC_SYSTEM_HAS_extractFloat32Exp}
{$define FPC_SYSTEM_HAS_extractFloat32Sign}
{$endif FPC_HAS_FEATURE_SOFTFPU}
{$endif FPUNONE}
procedure DebugWrite(S: PChar);
var
regs: Registers;
begin
while S^ <> #0 do begin
regs.C := $02;
regs.E := Ord(S^);
MsxDos(regs);
Inc(S);
end;
end;
procedure DebugWrite(const S: string);
var
regs: Registers;
i: Byte;
begin
for i := 1 to Length(S) do begin
regs.C := $02;
regs.E := Ord(S[i]);
MsxDos(regs);
end;
end;
procedure DebugWriteLn(const S: string);
begin
DebugWrite(S);
DebugWrite(#13#10);
end;
{*****************************************************************************
ParamStr/Randomize
*****************************************************************************}
var
internal_envp : PPChar = nil;
procedure setup_environment;
{$ifdef todo}
var
env_count : smallint;
cp, dos_env: PFarChar;
{$endif}
begin
{$ifdef todo}
env_count:=0;
dos_env:=Ptr(MemW[PrefixSeg:$2C], 0);
cp:=dos_env;
while cp^<>#0 do
begin
inc(env_count);
while (cp^ <> #0) do
inc(cp); { skip to NUL }
inc(cp); { skip to next character }
end;
internal_envp := getmem((env_count+1) * sizeof(PFarChar));
cp:=dos_env;
env_count:=0;
while cp^<>#0 do
begin
internal_envp[env_count] := cp;
inc(env_count);
while (cp^ <> #0) do
inc(cp); { skip to NUL }
inc(cp); { skip to next character }
end;
internal_envp[env_count]:=nil;
dos_env_count := env_count;
if dos_version >= $300 then
begin
if cp=dos_env then
inc(cp);
inc(cp, 3);
dos_argv0 := cp;
end
else
dos_argv0 := nil;
{$endif}
end;
function envp:PPChar;public name '__fpc_envp';
begin
if not assigned(internal_envp) then
setup_environment;
envp:=internal_envp;
end;
function GetEnvVar(aName: PChar): String;
var
regs: Registers;
i: SizeInt;
begin
SetLength(Result, 255);
regs.C := $6B;
regs.HL := PtrUInt(aName);
regs.DE := PtrUInt(@Result[1]);
regs.B := 255;
regs.A := 0;
MsxDos(regs);
if regs.A = 0 then begin
i := 1;
aName := PChar(@Result[1]);
while i < 256 do begin
if aName^ = #0 then begin
SetLength(Result, i);
Break;
end;
Inc(i);
Inc(aName);
end;
end else
SetLength(Result, 0);
end;
procedure setup_arguments;
var
i: SmallInt;
pc: PChar;
quote: Char;
count: SmallInt;
arglen, argv0len: SmallInt;
argblock: PChar;
arg: PChar;
doscmd : string[129]; { Dos commandline copied from PSP, max is 128 chars +1 for terminating zero }
tmp: String;
regs: Registers;
begin
tmp := GetEnvVar('PROGRAM');
argv0len := Length(tmp);
tmp := GetEnvVar('PARAMETERS');
{$IfDef SYSTEM_DEBUG_STARTUP}
Writeln(stderr,'Dos command line is #',tmp,'# size = ',length(tmp));
{$EndIf }
{ parse dos commandline }
pc:=@tmp[1];
count:=1;
{ calc total arguments length and count }
arglen:=argv0len+1;
while pc^<>#0 do
begin
{ skip leading spaces }
while pc^ in [#1..#32] do
inc(pc);
if pc^=#0 then
break;
{ calc argument length }
quote:=' ';
while (pc^<>#0) do
begin
case pc^ of
#1..#32 :
begin
if quote<>' ' then
inc(arglen)
else
break;
end;
'"' :
begin
if quote<>'''' then
begin
if pchar(pc+1)^<>'"' then
begin
if quote='"' then
quote:=' '
else
quote:='"';
end
else
inc(pc);
end
else
inc(arglen);
end;
'''' :
begin
if quote<>'"' then
begin
if pchar(pc+1)^<>'''' then
begin
if quote='''' then
quote:=' '
else
quote:='''';
end
else
inc(pc);
end
else
inc(arglen);
end;
else
inc(arglen);
end;
inc(pc);
end;
inc(arglen); { for the null terminator }
inc(count);
end;
Writeln(stderr,'Arg count: ', count, ', size: ', arglen);
{ set argc and allocate argv }
argc:=count;
argv:=AllocMem((count+1)*SizeOf(PChar));
{ allocate a single memory block for all arguments }
argblock:=GetMem(arglen);
writeln('Allocated arg vector at ', hexstr(argv), ' and block at ', hexstr(argblock));
{ create argv[0] }
argv[0]:=argblock;
arg:=argblock+argv0len;
arg^:=#0;
Inc(arg);
pc:=@tmp[1];
count:=1;
while pc^<>#0 do
begin
{ skip leading spaces }
while pc^ in [#1..#32] do
inc(pc);
if pc^=#0 then
break;
{ copy argument }
//writeln('Setting arg ',count,' to ', hexstr(arg));
asm
in a,(0x2e)
end ['a'];
argv[count]:=arg;
quote:=' ';
while (pc^<>#0) do
begin
case pc^ of
#1..#32 :
begin
if quote<>' ' then
begin
arg^:=pc^;
inc(arg);
end
else
break;
end;
'"' :
begin
if quote<>'''' then
begin
if pchar(pc+1)^<>'"' then
begin
if quote='"' then
quote:=' '
else
quote:='"';
end
else
inc(pc);
end
else
begin
arg^:=pc^;
inc(arg);
end;
end;
'''' :
begin
if quote<>'"' then
begin
if pchar(pc+1)^<>'''' then
begin
if quote='''' then
quote:=' '
else
quote:='''';
end
else
inc(pc);
end
else
begin
arg^:=pc^;
inc(arg);
end;
end;
else
begin
arg^:=pc^;
inc(arg);
end;
end;
inc(pc);
end;
arg^:=#0;
Inc(arg);
{$IfDef SYSTEM_DEBUG_STARTUP}
Writeln(stderr,'dos arg ',count,' #',strlen(argv[count]),'#',argv[count],'#');
{$EndIf SYSTEM_DEBUG_STARTUP}
inc(count);
end;
arg:=argblock;
tmp:=GetEnvVar('PROGRAM');
pc:=@tmp[1];
while pc^ <> #0 do
begin
arg^ := pc^;
Inc(arg);
Inc(pc);
end;
for count:=0 to argc-1 do
writeln('arg ',count,' at ',hexstr(argv[count]));
end;
function paramcount : longint;
begin
if argv=nil then
setup_arguments;
paramcount := argc - 1;
end;
function paramstr(l : longint) : string;
begin
if argv=nil then
setup_arguments;
if (l>=0) and (l+1<=argc) then
paramstr:=strpas(argv[l])
else
paramstr:='';
end;
procedure randomize;
{$ifdef todo}
var
hl : longint;
regs : Registers;
{$endif}
begin
{$ifdef todo}
regs.AH:=$2C;
MsDos(regs);
hl:=regs.DX;
randseed:=hl*$10000+ regs.CX;
{$endif}
end;
{*****************************************************************************
System Dependent Exit code
*****************************************************************************}
procedure system_exit;
var
h : byte;
begin
{$ifdef todo}
RestoreInterruptHandlers;
{$endif}
for h:=0 to max_files-1 do
if openfiles[h] then
begin
{$ifdef SYSTEMDEBUG}
writeln(stderr,'file ',h,' "',opennames[h],'" not closed at exit');
{$endif SYSTEMDEBUG}
if h>=5 then
do_close(h);
end;
{$ifndef FPC_MM_TINY}
{$ifdef todo}
if not CheckNullArea then
writeln(stderr, 'Nil pointer assignment');
{$endif}
{$endif FPC_MM_TINY}
asm
ld a, exitcode
ld b, a
ld c, 0x62
call 0x0005
end;
end;
{*****************************************************************************
SystemUnit Initialization
*****************************************************************************}
procedure InitDosHeap;
begin
RegisterTinyHeapBlock_Simple_Prealigned(@__fpc_initialheap,__heapsize);
end;
procedure SysInitStdIO;
begin
OpenStdIO(Input,fmInput,StdInputHandle);
OpenStdIO(Output,fmOutput,StdOutputHandle);
OpenStdIO(ErrOutput,fmOutput,StdErrorHandle);
{$ifndef FPC_STDOUT_TRUE_ALIAS}
OpenStdIO(StdOut,fmOutput,StdOutputHandle);
OpenStdIO(StdErr,fmOutput,StdErrorHandle);
{$endif FPC_STDOUT_TRUE_ALIAS}
end;
function GetProcessID: SizeUInt;
begin
GetProcessID := PrefixSeg;
end;
function CheckInitialStkLen(stklen : SizeUInt) : SizeUInt;
begin
result := stklen;
end;
procedure InitDosVersion;
var
regs: Registers;
begin
regs.C := $6F;
regs.A := 0;
MsxDos(regs);
if regs.A <> 0 then
dos_version := 0
else if regs.B < 2 then
dos_version := $100
else
dos_version := regs.DE;
end;
begin
StackLength := stklen;
StackBottom := __stktop - stklen;
InitDosVersion;
{ for now we don't support MSX-DOS 1 }
if dos_version < $100 then
Halt($85);
{$ifdef todo}
InstallInterruptHandlers;
{$endif}
{ To be set if this is a GUI or console application }
IsConsole := TRUE;
{$ifdef FPC_HAS_FEATURE_DYNLIBS}
{ If dynlibs feature is disabled,
IsLibrary is a constant, which can thus not be set to a value }
{ To be set if this is a library and not a program }
IsLibrary := FALSE;
{$endif def FPC_HAS_FEATURE_DYNLIBS}
{ Setup heap }
InitDosHeap;
SysInitExceptions;
{$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
initunicodestringmanager;
{$endif def FPC_HAS_FEATURE_UNICODESTRINGS}
{ Setup stdin, stdout and stderr }
SysInitStdIO;
{ Setup environment and arguments }
{ Done on request only Setup_Environment; }
{ Done on request only Setup_Arguments; }
{ Reset IO Error }
InOutRes:=0;
{$ifdef FPC_HAS_FEATURE_THREADING}
InitSystemThreads;
{$endif}
end.