mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-11-01 21:49:24 +01:00
* switch to a full blown win16 system unit
git-svn-id: trunk@31530 -
This commit is contained in:
nickysn
parent
4068a05631
commit
c2c008c09a
7
.gitattributes
vendored
7
.gitattributes
vendored
@ -9702,6 +9702,13 @@ rtl/win16/prt0l.asm svneol=native#text/plain
|
|||||||
rtl/win16/prt0m.asm svneol=native#text/plain
|
rtl/win16/prt0m.asm svneol=native#text/plain
|
||||||
rtl/win16/prt0s.asm svneol=native#text/plain
|
rtl/win16/prt0s.asm svneol=native#text/plain
|
||||||
rtl/win16/prt0t.asm svneol=native#text/plain
|
rtl/win16/prt0t.asm svneol=native#text/plain
|
||||||
|
rtl/win16/registers.inc svneol=native#text/plain
|
||||||
|
rtl/win16/rtldefs.inc svneol=native#text/plain
|
||||||
|
rtl/win16/sysdir.inc svneol=native#text/plain
|
||||||
|
rtl/win16/sysfile.inc svneol=native#text/plain
|
||||||
|
rtl/win16/sysheap.inc svneol=native#text/plain
|
||||||
|
rtl/win16/sysos.inc svneol=native#text/plain
|
||||||
|
rtl/win16/sysosh.inc svneol=native#text/plain
|
||||||
rtl/win16/system.pp svneol=native#text/plain
|
rtl/win16/system.pp svneol=native#text/plain
|
||||||
rtl/win32/Makefile svneol=native#text/plain
|
rtl/win32/Makefile svneol=native#text/plain
|
||||||
rtl/win32/Makefile.fpc svneol=native#text/plain
|
rtl/win32/Makefile.fpc svneol=native#text/plain
|
||||||
|
|||||||
9
rtl/win16/registers.inc
Normal file
9
rtl/win16/registers.inc
Normal file
@ -0,0 +1,9 @@
|
|||||||
|
{ Registers record used by Intr and MsDos. This include file is shared between
|
||||||
|
the system unit and the dos unit. }
|
||||||
|
|
||||||
|
type
|
||||||
|
Registers = packed record
|
||||||
|
case Integer of
|
||||||
|
0: (AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags: Word);
|
||||||
|
1: (AL, AH, BL, BH, CL, CH, DL, DH: Byte);
|
||||||
|
end;
|
||||||
24
rtl/win16/rtldefs.inc
Normal file
24
rtl/win16/rtldefs.inc
Normal 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}
|
||||||
139
rtl/win16/sysdir.inc
Normal file
139
rtl/win16/sysdir.inc
Normal file
@ -0,0 +1,139 @@
|
|||||||
|
{
|
||||||
|
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
|
||||||
|
*****************************************************************************}
|
||||||
|
|
||||||
|
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;
|
||||||
|
|
||||||
|
Procedure do_MkDir(const s: rawbytestring);
|
||||||
|
begin
|
||||||
|
{ DosDir($39,s);}
|
||||||
|
end;
|
||||||
|
|
||||||
|
Procedure do_RmDir(const s: rawbytestring);
|
||||||
|
begin
|
||||||
|
{ if s='.' then
|
||||||
|
begin
|
||||||
|
InOutRes:=16;
|
||||||
|
exit;
|
||||||
|
end;
|
||||||
|
DosDir($3a,s);}
|
||||||
|
end;
|
||||||
|
|
||||||
|
Procedure do_ChDir(const s: rawbytestring);
|
||||||
|
var
|
||||||
|
regs : Registers;
|
||||||
|
len : Integer;
|
||||||
|
begin
|
||||||
|
(* 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);*)
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure do_GetDir (DriveNr: byte; var Dir: RawByteString);
|
||||||
|
var
|
||||||
|
temp : array[0..260] of char;
|
||||||
|
i : integer;
|
||||||
|
regs : Registers;
|
||||||
|
begin
|
||||||
|
(* 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;*)
|
||||||
|
end;
|
||||||
401
rtl/win16/sysfile.inc
Normal file
401
rtl/win16/sysfile.inc
Normal file
@ -0,0 +1,401 @@
|
|||||||
|
{
|
||||||
|
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;}
|
||||||
|
{$endif SYSTEMDEBUG}
|
||||||
|
|
||||||
|
|
||||||
|
{****************************************************************************
|
||||||
|
Low level File Routines
|
||||||
|
****************************************************************************}
|
||||||
|
|
||||||
|
procedure do_close(handle : thandle);
|
||||||
|
var
|
||||||
|
regs : Registers;
|
||||||
|
begin
|
||||||
|
(* if Handle<=4 then
|
||||||
|
exit;
|
||||||
|
regs.BX:=handle;
|
||||||
|
if handle<max_files then
|
||||||
|
begin
|
||||||
|
openfiles[handle]:=false;
|
||||||
|
{$ifdef SYSTEMDEBUG}
|
||||||
|
if assigned(opennames[handle]) and free_closed_names then
|
||||||
|
begin
|
||||||
|
sysfreememsize(opennames[handle],strlen(opennames[handle])+1);
|
||||||
|
opennames[handle]:=nil;
|
||||||
|
end;
|
||||||
|
{$endif SYSTEMDEBUG}
|
||||||
|
end;
|
||||||
|
regs.AX:=$3e00;
|
||||||
|
MsDos(regs);
|
||||||
|
if (regs.Flags and fCarry) <> 0 then
|
||||||
|
GetInOutRes(regs.AX);*)
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure do_erase(p : pchar; pchangeable: boolean);
|
||||||
|
var
|
||||||
|
regs : Registers;
|
||||||
|
oldp : pchar;
|
||||||
|
begin
|
||||||
|
(* oldp:=p;
|
||||||
|
DoDirSeparators(p,pchangeable);
|
||||||
|
regs.DX:=Ofs(p^);
|
||||||
|
regs.DS:=Seg(p^);
|
||||||
|
if LFNSupport then
|
||||||
|
regs.AX:=$7141
|
||||||
|
else
|
||||||
|
regs.AX:=$4100;
|
||||||
|
regs.SI:=0;
|
||||||
|
regs.CX:=0;
|
||||||
|
MsDos(regs);
|
||||||
|
if (regs.Flags and fCarry) <> 0 then
|
||||||
|
GetInOutRes(regs.AX);
|
||||||
|
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.DS:=Seg(p1^);
|
||||||
|
regs.DX:=Ofs(p1^);
|
||||||
|
regs.ES:=Seg(p2^);
|
||||||
|
regs.DI:=Ofs(p2^);
|
||||||
|
if LFNSupport then
|
||||||
|
regs.AX:=$7156
|
||||||
|
else
|
||||||
|
regs.AX:=$5600;
|
||||||
|
regs.CX:=$ff; { attribute problem here ! }
|
||||||
|
MsDos(regs);
|
||||||
|
if (regs.Flags and fCarry) <> 0 then
|
||||||
|
GetInOutRes(regs.AX);
|
||||||
|
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.AH := $40;
|
||||||
|
regs.BX := h;
|
||||||
|
regs.CX := len;
|
||||||
|
regs.DS := Seg(addr^);
|
||||||
|
regs.DX := Ofs(addr^);
|
||||||
|
MsDos(regs);
|
||||||
|
if (regs.Flags and fCarry) <> 0 then
|
||||||
|
begin
|
||||||
|
GetInOutRes(regs.AX);
|
||||||
|
exit(0);
|
||||||
|
end;
|
||||||
|
do_write := regs.AX;*)
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
function do_read(h:thandle;addr:pointer;len : longint) : longint;
|
||||||
|
var
|
||||||
|
regs: Registers;
|
||||||
|
begin
|
||||||
|
(* regs.AH := $3F;
|
||||||
|
regs.BX := h;
|
||||||
|
regs.CX := len;
|
||||||
|
regs.DS := Seg(addr^);
|
||||||
|
regs.DX := Ofs(addr^);
|
||||||
|
MsDos(regs);
|
||||||
|
if (regs.Flags and fCarry) <> 0 then
|
||||||
|
begin
|
||||||
|
GetInOutRes(regs.AX);
|
||||||
|
exit(0);
|
||||||
|
end;
|
||||||
|
do_read := regs.AX;*)
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
function do_filepos(handle : thandle) : longint;
|
||||||
|
var
|
||||||
|
regs : Registers;
|
||||||
|
begin
|
||||||
|
(* regs.BX:=handle;
|
||||||
|
regs.CX:=0;
|
||||||
|
regs.DX:=0;
|
||||||
|
regs.AX:=$4201;
|
||||||
|
MsDos(regs);
|
||||||
|
if (regs.Flags and fCarry) <> 0 then
|
||||||
|
Begin
|
||||||
|
GetInOutRes(regs.AX);
|
||||||
|
do_filepos:=0;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
do_filepos:=(longint(regs.DX) shl 16) + regs.AX;*)
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
procedure do_seek(handle:thandle;pos : longint);
|
||||||
|
var
|
||||||
|
regs : Registers;
|
||||||
|
begin
|
||||||
|
(* regs.BX:=handle;
|
||||||
|
regs.CX:=pos shr 16;
|
||||||
|
regs.DX:=pos and $ffff;
|
||||||
|
regs.AX:=$4200;
|
||||||
|
MsDos(regs);
|
||||||
|
if (regs.Flags and fCarry) <> 0 then
|
||||||
|
GetInOutRes(regs.AX);*)
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
function do_seekend(handle:thandle):longint;
|
||||||
|
var
|
||||||
|
regs : Registers;
|
||||||
|
begin
|
||||||
|
(* regs.BX:=handle;
|
||||||
|
regs.CX:=0;
|
||||||
|
regs.DX:=0;
|
||||||
|
regs.AX:=$4202;
|
||||||
|
MsDos(regs);
|
||||||
|
if (regs.Flags and fCarry) <> 0 then
|
||||||
|
Begin
|
||||||
|
GetInOutRes(regs.AX);
|
||||||
|
do_seekend:=0;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
do_seekend:=(longint(regs.DX) shl 16) + regs.AX;*)
|
||||||
|
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
|
||||||
|
{ do_seek(handle,pos);
|
||||||
|
regs.CX:=0;
|
||||||
|
regs.BX:=handle;
|
||||||
|
regs.AX:=$4000;
|
||||||
|
MsDos(regs);
|
||||||
|
if (regs.Flags and fCarry) <> 0 then
|
||||||
|
GetInOutRes(regs.AX);}
|
||||||
|
end;
|
||||||
|
|
||||||
|
{const
|
||||||
|
FileHandleCount : word = 20;
|
||||||
|
|
||||||
|
function Increase_file_handle_count : boolean;
|
||||||
|
var
|
||||||
|
regs : Registers;
|
||||||
|
begin
|
||||||
|
Inc(FileHandleCount,10);
|
||||||
|
regs.BX:=FileHandleCount;
|
||||||
|
regs.AX:=$6700;
|
||||||
|
MsDos(regs);
|
||||||
|
if (regs.Flags and fCarry) <> 0 then
|
||||||
|
begin
|
||||||
|
Increase_file_handle_count:=false;
|
||||||
|
Dec (FileHandleCount, 10);
|
||||||
|
end
|
||||||
|
else
|
||||||
|
Increase_file_handle_count:=true;
|
||||||
|
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
|
||||||
|
{ 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 }
|
||||||
|
case (flags and 3) of
|
||||||
|
0 : filerec(f).mode:=fminput;
|
||||||
|
1 : filerec(f).mode:=fmoutput;
|
||||||
|
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);
|
||||||
|
{$ifndef RTLLITE}
|
||||||
|
if LFNSupport then
|
||||||
|
begin
|
||||||
|
regs.AX := $716c; { Use LFN Open/Create API }
|
||||||
|
regs.DX := action; { action if file does/doesn't exist }
|
||||||
|
regs.SI := Ofs(p^);
|
||||||
|
regs.BX := $2000 + (flags and $ff); { file open mode }
|
||||||
|
end
|
||||||
|
else
|
||||||
|
{$endif RTLLITE}
|
||||||
|
begin
|
||||||
|
if (action and $00f0) <> 0 then
|
||||||
|
regs.AX := $3c00 { Map to Create/Replace API }
|
||||||
|
else
|
||||||
|
regs.AX := $3d00 + (flags and $ff); { Map to Open_Existing API }
|
||||||
|
regs.DX := Ofs(p^);
|
||||||
|
end;
|
||||||
|
regs.DS := Seg(p^);
|
||||||
|
regs.CX := $20; { file attributes }
|
||||||
|
MsDos(regs);
|
||||||
|
{$ifndef RTLLITE}
|
||||||
|
if (regs.Flags and fCarry) <> 0 then
|
||||||
|
if regs.AX=4 then
|
||||||
|
if Increase_file_handle_count then
|
||||||
|
begin
|
||||||
|
{ Try again }
|
||||||
|
if LFNSupport then
|
||||||
|
begin
|
||||||
|
regs.AX := $716c; {Use LFN Open/Create API}
|
||||||
|
regs.DX := action; {action if file does/doesn't exist}
|
||||||
|
regs.SI := Ofs(p^);
|
||||||
|
regs.BX := $2000 + (flags and $ff); {file open mode}
|
||||||
|
end
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
if (action and $00f0) <> 0 then
|
||||||
|
regs.AX := $3c00 {Map to Create/Replace API}
|
||||||
|
else
|
||||||
|
regs.AX := $3d00 + (flags and $ff); {Map to Open API}
|
||||||
|
regs.DX := Ofs(p^);
|
||||||
|
end;
|
||||||
|
regs.DS := Seg(p^);
|
||||||
|
regs.CX := $20; {file attributes}
|
||||||
|
MsDos(regs);
|
||||||
|
end;
|
||||||
|
{$endif RTLLITE}
|
||||||
|
if (regs.Flags and fCarry) <> 0 then
|
||||||
|
begin
|
||||||
|
FileRec(f).mode:=fmclosed;
|
||||||
|
GetInOutRes(regs.AX);
|
||||||
|
if oldp<>p then
|
||||||
|
freemem(p);
|
||||||
|
exit;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
filerec(f).handle:=regs.AX;
|
||||||
|
{$ifndef RTLLITE}
|
||||||
|
{ for systems that have more then 20 by default ! }
|
||||||
|
if regs.AX>FileHandleCount then
|
||||||
|
FileHandleCount:=regs.AX;
|
||||||
|
{$endif RTLLITE}
|
||||||
|
end;
|
||||||
|
if regs.AX<max_files then
|
||||||
|
begin
|
||||||
|
{$ifdef SYSTEMDEBUG}
|
||||||
|
if openfiles[regs.AX] and
|
||||||
|
assigned(opennames[regs.AX]) then
|
||||||
|
begin
|
||||||
|
Writeln(stderr,'file ',opennames[regs.AX],'(',regs.AX,') not closed but handle reused!');
|
||||||
|
sysfreememsize(opennames[regs.AX],strlen(opennames[regs.AX])+1);
|
||||||
|
end;
|
||||||
|
{$endif SYSTEMDEBUG}
|
||||||
|
openfiles[regs.AX]:=true;
|
||||||
|
{$ifdef SYSTEMDEBUG}
|
||||||
|
opennames[regs.AX] := sysgetmem(strlen(p)+1);
|
||||||
|
move(p^,opennames[regs.AX]^,strlen(p)+1);
|
||||||
|
{$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.AX := $4400;
|
||||||
|
regs.BX := handle;
|
||||||
|
MsDos(regs);
|
||||||
|
do_isdevice := (regs.DL and $80) <> 0;
|
||||||
|
if (regs.Flags and fCarry) <> 0 then
|
||||||
|
GetInOutRes(regs.AX);*)
|
||||||
|
end;
|
||||||
30
rtl/win16/sysheap.inc
Normal file
30
rtl/win16/sysheap.inc
Normal file
@ -0,0 +1,30 @@
|
|||||||
|
{
|
||||||
|
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
|
||||||
|
*****************************************************************************}
|
||||||
|
|
||||||
|
function SysOSAlloc (size: ptruint): pointer;
|
||||||
|
begin
|
||||||
|
Result := nil;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure SysOSFree(p: pointer; size: ptruint);
|
||||||
|
begin
|
||||||
|
end;
|
||||||
34
rtl/win16/sysos.inc
Normal file
34
rtl/win16/sysos.inc
Normal file
@ -0,0 +1,34 @@
|
|||||||
|
{
|
||||||
|
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.AX:=$5900;
|
||||||
|
regs.BX:=$0;
|
||||||
|
MsDos(regs);
|
||||||
|
InOutRes:=regs.AX;
|
||||||
|
case InOutRes of
|
||||||
|
19 : InOutRes:=150;
|
||||||
|
21 : InOutRes:=152;
|
||||||
|
32 : InOutRes:=5;
|
||||||
|
end;
|
||||||
|
if InOutRes=0 then
|
||||||
|
InOutRes:=Def;}
|
||||||
|
end;
|
||||||
|
|
||||||
26
rtl/win16/sysosh.inc
Normal file
26
rtl/win16/sysosh.inc
Normal file
@ -0,0 +1,26 @@
|
|||||||
|
{
|
||||||
|
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 = Word;
|
||||||
|
TThreadID = THandle;
|
||||||
|
|
||||||
|
PRTLCriticalSection = ^TRTLCriticalSection;
|
||||||
|
TRTLCriticalSection = record
|
||||||
|
Locked: boolean
|
||||||
|
end;
|
||||||
@ -2,31 +2,294 @@ unit system;
|
|||||||
|
|
||||||
interface
|
interface
|
||||||
|
|
||||||
type
|
{$DEFINE FPC_NO_DEFAULT_HEAP}
|
||||||
HResult=word;
|
|
||||||
LPCTSTR=^char;far;
|
{$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 }
|
||||||
|
|
||||||
|
{$I systemh.inc}
|
||||||
|
{$I tnyheaph.inc}
|
||||||
|
|
||||||
|
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;
|
||||||
|
StdErrorHandle = 2;
|
||||||
|
|
||||||
|
FileNameCaseSensitive : boolean = false;
|
||||||
|
FileNameCasePreserving: boolean = false;
|
||||||
|
CtrlZMarksEOF: boolean = true; (* #26 is considered as end of file *)
|
||||||
|
|
||||||
|
sLineBreak = LineEnding;
|
||||||
|
DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsCRLF;
|
||||||
|
|
||||||
|
{ Default memory segments (Tp7 compatibility) }
|
||||||
|
{ seg0040: Word = $0040;
|
||||||
|
segA000: Word = $A000;
|
||||||
|
segB000: Word = $B000;
|
||||||
|
segB800: Word = $B800;}
|
||||||
|
{ The value that needs to be added to the segment to move the pointer by
|
||||||
|
64K bytes (BP7 compatibility) }
|
||||||
|
SelectorInc: Word = $1000;
|
||||||
|
|
||||||
|
var
|
||||||
|
{ Mem[] support }
|
||||||
|
mem : array[0..$7fff-1] of byte absolute $0:$0;
|
||||||
|
memw : array[0..($7fff div sizeof(word))-1] of word absolute $0:$0;
|
||||||
|
meml : array[0..($7fff div sizeof(longint))-1] of longint absolute $0:$0;
|
||||||
|
{ C-compatible arguments and environment }
|
||||||
|
argc:longint; //!! public name 'operatingsystem_parameter_argc';
|
||||||
|
argv:PPchar; //!! public name 'operatingsystem_parameter_argv';
|
||||||
|
envp:PPchar; //!! public name 'operatingsystem_parameter_envp';
|
||||||
|
dos_argv0 : pchar; //!! public name 'dos_argv0';
|
||||||
|
|
||||||
|
{ The DOS Program Segment Prefix segment (TP7 compatibility) }
|
||||||
|
PrefixSeg:Word;public name '__fpc_PrefixSeg';
|
||||||
|
|
||||||
|
{ SaveInt00: FarPointer;public name '__SaveInt00';}
|
||||||
|
|
||||||
|
AllFilesMask: string [3];
|
||||||
|
{$ifndef RTLLITE}
|
||||||
|
{ System info }
|
||||||
|
LFNSupport : boolean;
|
||||||
|
{$ELSE RTLLITE}
|
||||||
|
const
|
||||||
|
LFNSupport = false;
|
||||||
|
{$endif RTLLITE}
|
||||||
|
|
||||||
procedure fpc_InitializeUnits;compilerproc;
|
|
||||||
procedure fpc_do_exit;compilerproc;
|
|
||||||
|
|
||||||
procedure InitTask;external 'KERNEL';
|
procedure InitTask;external 'KERNEL';
|
||||||
procedure WaitEvent;external 'KERNEL';
|
procedure WaitEvent;external 'KERNEL';
|
||||||
procedure InitApp;external 'USER';
|
procedure InitApp;external 'USER';
|
||||||
procedure MessageBox(hWnd: word; lpText, lpCaption: LPCTSTR; uType: word);external 'USER';
|
procedure MessageBox(hWnd: word; lpText, lpCaption: PChar; uType: word);external 'USER';
|
||||||
|
|
||||||
implementation
|
implementation
|
||||||
|
|
||||||
procedure fpc_InitializeUnits;[public,alias:'FPC_INITIALIZEUNITS'];compilerproc;
|
const
|
||||||
|
fCarry = 1;
|
||||||
|
|
||||||
|
{ 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;
|
||||||
|
|
||||||
|
{$I registers.inc}
|
||||||
|
|
||||||
|
{$I system.inc}
|
||||||
|
|
||||||
|
{$I tinyheap.inc}
|
||||||
|
|
||||||
|
{procedure fpc_InitializeUnits;[public,alias:'FPC_INITIALIZEUNITS'];compilerproc;
|
||||||
begin
|
begin
|
||||||
MessageBox(0, 'Hello, world!', 'yo', 0);
|
MessageBox(0, 'Hello, world!', 'yo', 0);
|
||||||
end;
|
end;}
|
||||||
|
|
||||||
procedure fpc_do_exit;[public,alias:'FPC_DO_EXIT'];compilerproc;
|
{procedure fpc_do_exit;[public,alias:'FPC_DO_EXIT'];compilerproc;
|
||||||
begin
|
begin
|
||||||
asm
|
asm
|
||||||
mov ax, 4c00h
|
mov ax, 4c00h
|
||||||
int 21h
|
int 21h
|
||||||
end;
|
end;
|
||||||
|
end;}
|
||||||
|
{*****************************************************************************
|
||||||
|
ParamStr/Randomize
|
||||||
|
*****************************************************************************}
|
||||||
|
|
||||||
|
{function GetProgramName: string;
|
||||||
|
var
|
||||||
|
dos_env_seg: Word;
|
||||||
|
ofs: Word;
|
||||||
|
Ch, Ch2: Char;
|
||||||
|
begin
|
||||||
|
if dos_version < $300 then
|
||||||
|
begin
|
||||||
|
GetProgramName := '';
|
||||||
|
exit;
|
||||||
|
end;
|
||||||
|
dos_env_seg := PFarWord(Ptr(PrefixSeg, $2C))^;
|
||||||
|
ofs := 1;
|
||||||
|
repeat
|
||||||
|
Ch := PFarChar(Ptr(dos_env_seg,ofs - 1))^;
|
||||||
|
Ch2 := PFarChar(Ptr(dos_env_seg,ofs))^;
|
||||||
|
if (Ch = #0) and (Ch2 = #0) then
|
||||||
|
begin
|
||||||
|
Inc(ofs, 3);
|
||||||
|
GetProgramName := '';
|
||||||
|
repeat
|
||||||
|
Ch := PFarChar(Ptr(dos_env_seg,ofs))^;
|
||||||
|
if Ch <> #0 then
|
||||||
|
GetProgramName := GetProgramName + Ch;
|
||||||
|
Inc(ofs);
|
||||||
|
if ofs = 0 then
|
||||||
|
begin
|
||||||
|
GetProgramName := '';
|
||||||
|
exit;
|
||||||
|
end;
|
||||||
|
until Ch = #0;
|
||||||
|
exit;
|
||||||
|
end;
|
||||||
|
Inc(ofs);
|
||||||
|
if ofs = 0 then
|
||||||
|
begin
|
||||||
|
GetProgramName := '';
|
||||||
|
exit;
|
||||||
|
end;
|
||||||
|
until false;
|
||||||
|
end;}
|
||||||
|
|
||||||
|
|
||||||
|
{function GetCommandLine: string;
|
||||||
|
var
|
||||||
|
len, I: Integer;
|
||||||
|
begin
|
||||||
|
len := PFarByte(Ptr(PrefixSeg, $80))^;
|
||||||
|
SetLength(GetCommandLine, len);
|
||||||
|
for I := 1 to len do
|
||||||
|
GetCommandLine[I] := PFarChar(Ptr(PrefixSeg, $80 + I))^;
|
||||||
|
end;}
|
||||||
|
|
||||||
|
|
||||||
|
{function GetArg(ArgNo: Integer; out ArgResult: string): Integer;
|
||||||
|
var
|
||||||
|
cmdln: string;
|
||||||
|
I: Integer;
|
||||||
|
InArg: Boolean;
|
||||||
|
begin
|
||||||
|
cmdln := GetCommandLine;
|
||||||
|
ArgResult := '';
|
||||||
|
I := 1;
|
||||||
|
InArg := False;
|
||||||
|
GetArg := 0;
|
||||||
|
for I := 1 to Length(cmdln) do
|
||||||
|
begin
|
||||||
|
if not InArg and (cmdln[I] <> ' ') then
|
||||||
|
begin
|
||||||
|
InArg := True;
|
||||||
|
Inc(GetArg);
|
||||||
|
end;
|
||||||
|
if InArg and (cmdln[I] = ' ') then
|
||||||
|
InArg := False;
|
||||||
|
if InArg and (GetArg = ArgNo) then
|
||||||
|
ArgResult := ArgResult + cmdln[I];
|
||||||
|
end;
|
||||||
|
end;}
|
||||||
|
|
||||||
|
|
||||||
|
function paramcount : longint;
|
||||||
|
{var
|
||||||
|
tmpstr: string;}
|
||||||
|
begin
|
||||||
|
{ paramcount := GetArg(-1, tmpstr);}
|
||||||
|
paramcount:=0;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
function paramstr(l : longint) : string;
|
||||||
|
begin
|
||||||
|
{ if l = 0 then
|
||||||
|
paramstr := GetProgramName
|
||||||
|
else
|
||||||
|
GetArg(l, paramstr);}
|
||||||
|
paramstr:='';
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure randomize;
|
||||||
|
{var
|
||||||
|
hl : longint;
|
||||||
|
regs : Registers;}
|
||||||
|
begin
|
||||||
|
{ regs.AH:=$2C;
|
||||||
|
MsDos(regs);
|
||||||
|
hl:=regs.DX;
|
||||||
|
randseed:=hl*$10000+ regs.CX;}
|
||||||
|
end;
|
||||||
|
|
||||||
|
{*****************************************************************************
|
||||||
|
System Dependent Exit code
|
||||||
|
*****************************************************************************}
|
||||||
|
|
||||||
|
procedure system_exit;
|
||||||
|
{var
|
||||||
|
h : byte;}
|
||||||
|
begin
|
||||||
|
(* RestoreInterruptHandlers;
|
||||||
|
for h:=0 to max_files-1 do
|
||||||
|
if openfiles[h] then
|
||||||
|
begin
|
||||||
|
{$ifdef SYSTEMDEBUG}
|
||||||
|
writeln(stderr,'file ',opennames[h],' not closed at exit');
|
||||||
|
{$endif SYSTEMDEBUG}
|
||||||
|
if h>=5 then
|
||||||
|
do_close(h);
|
||||||
|
end;
|
||||||
|
{$ifndef FPC_MM_TINY}
|
||||||
|
if not CheckNullArea then
|
||||||
|
writeln(stderr, 'Nil pointer assignment');
|
||||||
|
{$endif FPC_MM_TINY}*)
|
||||||
|
asm
|
||||||
|
mov al, byte [exitcode]
|
||||||
|
mov ah, 4Ch
|
||||||
|
int 21h
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{*****************************************************************************
|
||||||
|
SystemUnit Initialization
|
||||||
|
*****************************************************************************}
|
||||||
|
|
||||||
|
procedure SysInitStdIO;
|
||||||
|
begin
|
||||||
|
OpenStdIO(Input,fmInput,StdInputHandle);
|
||||||
|
OpenStdIO(Output,fmOutput,StdOutputHandle);
|
||||||
|
OpenStdIO(ErrOutput,fmOutput,StdErrorHandle);
|
||||||
|
OpenStdIO(StdOut,fmOutput,StdOutputHandle);
|
||||||
|
OpenStdIO(StdErr,fmOutput,StdErrorHandle);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetProcessID: SizeUInt;
|
||||||
|
begin
|
||||||
|
GetProcessID := PrefixSeg;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function CheckInitialStkLen(stklen : SizeUInt) : SizeUInt;
|
||||||
|
begin
|
||||||
|
result := stklen;
|
||||||
|
end;
|
||||||
|
|
||||||
|
begin
|
||||||
|
MessageBox(0, 'Hello, world!', 'yo', 0);
|
||||||
end.
|
end.
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user