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

sinclairql: initial implementation of RTL file I/O functions, patch by Marcel Kilgus in qlforum.co.uk

Browse Source 
git-svn-id: trunk@47561 -
This commit is contained in:
Károly Balogh 2020-11-24 19:28:47 +00:00
parent ab2db33b4c
commit aa1bbb591c
1 changed files with 37 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
rtl/sinclairql/sysfile.inc
View File

@ -50,37 +50,67 @@ end;
function do_read(h: longint; addr: pointer; len: longint) : longint;
var
res: longint;
begin
do_read:=-1;
do_read := 0;
res := io_fline(h, -1, addr, len);
if res < 0 then
Error2InOutRes(res)
else
do_read := res;
end;
function do_filepos(handle: longint) : longint;
function do_filepos(handle: longint): longint;
var
res: longint;
begin
do_filepos:=-1;
do_filepos := 0;
res := fs_posre(handle, 0);
if res < 0 then
Error2InOutRes(res)
else
do_filepos := res;
end;
procedure do_seek(handle, pos: longint);
var
res: longint;
begin
res := fs_posab(handle, pos);
if res < 0 then
Error2InOutRes(res);
end;
function do_seekend(handle: longint):longint;
function do_seekend(handle: longint): longint;
begin
do_seekend:=-1;
do_seek(handle, -1);
do_seekend := do_filepos(handle);
end;
function do_filesize(handle : THandle) : longint;
function do_filesize(handle: longint): longint;
var
res: longint;
header: array [0..$39] of byte;
begin
do_filesize:=-1;
do_filesize := 0;
res := fs_headr(handle, @header, $40);
if res < 0 then
Error2InOutRes(res)
else
do_filesize := plongint(@header[0])^;
end;
{ truncate at a given position }
procedure do_truncate(handle, pos: longint);
begin
do_seek(handle, pos);
fs_truncate(handle);
end;