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

sinclairql: various seeking, FS_POSAB/FS_POSRE and ERR_EF related fixes

Browse Source 
git-svn-id: trunk@49169 -
This commit is contained in:
Károly Balogh 2021-04-10 15:15:12 +00:00
parent f3a19aaf59
commit fc26e2629b
3 changed files with 38 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
rtl/sinclairql/qdos.inc
View File

@ -24,12 +24,12 @@ const
procedure mt_frjob(jobID: Tjobid; exitCode: longint); assembler; nostackframe; public name '_mt_frjob';
asm
movem.l d2-d3,-(sp)
movem.l d2-d3/a2-a3,-(sp)
move.l exitCode,d3
move.l jobID,d1
moveq #_MT_FRJOB,d0
trap #1
movem.l (sp)+,d2-d3
movem.l (sp)+,d2-d3/a2-a3
end;
function mt_inf(sys_vars: ppchar; ver_ascii: plongint): Tjobid; assembler; nostackframe; public name '_mt_inf';
@ -287,35 +287,28 @@ asm
move.l (sp)+,d3
end;
function fs_posab(chan: Tchanid; new_pos: dword): longint; assembler; nostackframe; public name '_fs_posab';
function fs_posab(chan: Tchanid; var new_pos: longint): longint; assembler; nostackframe; public name '_fs_posab';
asm
move.l d3,-(sp)
movem.l d3/a0,-(sp) { a0 = new_pos }
move.l (a0),d1
move.l chan,a0
move.l new_pos,d1
moveq #-1,d3
moveq #_FS_POSAB,d0
trap #3
tst.l d0
bne.s @quit
move.l d1,d0
@quit:
move.l (sp)+,d3
movem.l (sp)+,d3/a0
move.l d1,(a0)
end;
function fs_posre(chan: Tchanid; new_pos: dword): longint; assembler; nostackframe; public name '_fs_posre';
function fs_posre(chan: Tchanid; var new_pos: longint): longint; assembler; nostackframe; public name '_fs_posre';
asm
move.l d3,-(sp)
movem.l d3/a0,-(sp) { a0 = new_pos }
move.l (a0),d1
move.l chan,a0
move.l new_pos,d1
moveq #-1,d3
moveq #_FS_POSRE,d0
trap #3
tst.l d0
bne.s @quit
move.l d1,d0
@quit:
move.l (sp)+,d3
movem.l (sp)+,d3/a0
move.l d1,(a0)
end;
function fs_headr(chan: Tchanid; buf: pointer; buf_size: word): longint; assembler; nostackframe; public name '_fs_headr';

4
rtl/sinclairql/qdosfuncs.inc
View File

@ -34,8 +34,8 @@ function io_fstrg(chan: Tchanid; timeout: Ttimeout; buf: pointer; len: word): lo
function io_sbyte(chan: Tchanid; timeout: Ttimeout; c: char): longint; external name '_io_sbyte';
function io_sstrg(chan: Tchanid; timeout: Ttimeout; buf: pointer; len: word): longint; external name '_io_sstrg';
function fs_posab(chan: Tchanid; new_pos: dword): longint; external name '_fs_posab';
function fs_posre(chan: Tchanid; new_pos: dword): longint; external name '_fs_posre';
function fs_posab(chan: Tchanid; var new_pos: longint): longint; external name '_fs_posab';
function fs_posre(chan: Tchanid; var new_pos: longint): longint; external name '_fs_posre';
function fs_headr(chan: Tchanid; buf: pointer; buf_size: word): longint; external name '_fs_headr';
function fs_truncate(chan: Tchanid): longint; external name '_fs_truncate';

30
rtl/sinclairql/sysfile.inc
View File

@ -56,6 +56,8 @@ var
begin
do_read := 0;
res := io_fline(h, -1, addr, len);
if res = ERR_EF then
res := 0;
if res < 0 then
Error2InOutRes(res)
else
@ -66,13 +68,17 @@ end;
function do_filepos(handle: longint): longint;
var
res: longint;
pos: longint;
begin
do_filepos := 0;
res := fs_posre(handle, 0);
if (res < 0) and (res <> ERR_EF) then
pos := 0;
res := fs_posre(handle, pos);
if res = ERR_EF then
res := 0;
if (res < 0) then
Error2InOutRes(res)
else
do_filepos := res;
do_filepos := pos;
end;
@ -81,7 +87,9 @@ var
res: longint;
begin
res := fs_posab(handle, pos);
if (res < 0) and (res <> ERR_EF) then
if res = ERR_EF then
res := 0;
if (res < 0) then
Error2InOutRes(res);
end;
@ -93,9 +101,19 @@ const
MAX_QL_FILE_LENGTH = $7FFFFFBF;
function do_seekend(handle: longint): longint;
var
res: longint;
pos: longint;
begin
do_seek(handle, MAX_QL_FILE_LENGTH);
do_seekend := do_filepos(handle);
do_seekend:=-1;
pos:=MAX_QL_FILE_LENGTH;
res:=fs_posab(handle, pos);
if res = ERR_EF then
res := 0;
if res < 0 then
Error2InOutRes(res)
else
do_seekend := pos;
end;