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

sinclairql: implemented do_rename(), based on the patch of Norman Dunbar

Browse Source 
git-svn-id: trunk@49171 -
This commit is contained in:
Károly Balogh 2021-04-10 17:04:47 +00:00
parent 992fa3eea7
commit 541c65feb7
3 changed files with 62 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
rtl/sinclairql/qdos.inc
View File

@ -175,6 +175,7 @@ const
_FS_POSAB = $42;
_FS_POSRE = $43;
_FS_HEADR = $47;
_FS_RENAME = $4A;
_FS_TRUNCATE = $4B;
function io_fbyte(chan: Tchanid; timeout: Ttimeout): longint; assembler; nostackframe; public name '_io_fbyte';
@ -327,6 +328,32 @@ asm
movem.l (sp)+,d2-d3
end;
function fs_rename_qlstr(chan: Tchanid; new_name_as_qlstr: pointer): longint; assembler; nostackframe; public name '_fs_rename_qlstr';
asm
move.l d3,-(sp)
move.l new_name_as_qlstr,a1
move.l chan,a0
moveq #-1,d3
moveq #_FS_RENAME,d0
trap #3
move.l (sp)+,d3
end;
function fs_rename(chan: Tchanid; new_name: pchar): longint; public name '_fs_rename';
var
len: longint;
new_name_qlstr: array[0..63] of char;
begin
len:=length(new_name);
if len > length(new_name_qlstr)-2 then
len:=length(new_name_qlstr)-2;
PWord(@new_name_qlstr)[0]:=len;
Move(new_name^,new_name_qlstr[2],len);
fs_rename:=fs_rename_qlstr(chan,@new_name_qlstr);
end;
function fs_truncate(chan: Tchanid): longint; assembler; nostackframe; public name '_fs_truncate';
asm
move.l d3,-(sp)

2
rtl/sinclairql/qdosfuncs.inc
View File

@ -37,6 +37,8 @@ function io_sstrg(chan: Tchanid; timeout: Ttimeout; buf: pointer; len: word): lo
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_rename_qlstr(chan: Tchanid; new_name_as_qlstr: pointer): longint; external name '_fs_rename_qlstr';
function fs_rename(chan: Tchanid; new_name: pchar): longint; external name '_fs_rename';
function fs_truncate(chan: Tchanid): longint; external name '_fs_truncate';
function sd_wdef(chan: Tchanid; timeout: Ttimeout; border_colour: byte; border_width: word; window: PQLRect): longint; external name '_sd_wdef';

33
rtl/sinclairql/sysfile.inc
View File

@ -33,7 +33,40 @@ end;
procedure do_rename(p1,p2 : pchar; p1changeable, p2changeable: boolean);
var
chanId: longint;
res: longint;
begin
{ To rename a QL file, it must exist and be opened. For WIN/FLP this
means open mode 0 (Q_OPEN) but for RAM this can be any of Q_OPEN,
Q_OPEN_NEW or Q_OPEN_OVER. }
{ Does the file exist? }
chanId := io_open(p1, Q_OPEN_IN);
if chanId < 0 then
begin
InOutRes:=2; { File not found. }
exit;
end;
{ Close and reopen in correct mode. }
io_close(chanId);
chanId := io_open(p1, Q_OPEN);
if chanId < 0 then
begin
Error2InOutRes(chanId);
exit;
end;
{ Now, finally, we can rename. }
res := fs_rename(chanId,p2);
{ Close the file. Never errors out. }
io_close(chanId);
if res < 0 then
Error2InOutRes(res);
end;