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

git-svn-id: https://svn.freepascal.org/svn/fpc/trunk@49171 3ad0048d-3df7-0310-abae-a5850022a9f2

3 files changed, 62 insertions, 0 deletions

diff --git a/rtl/sinclairql/qdos.inc b/rtl/sinclairql/qdos.inc
index 8d05240791..2f03d1d9c2 100644
--- a/rtl/sinclairql/qdos.inc
+++ b/rtl/sinclairql/qdos.inc
@@ -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)
diff --git a/rtl/sinclairql/qdosfuncs.inc b/rtl/sinclairql/qdosfuncs.inc
index d6840b3a08..4c73a7a131 100644
--- a/rtl/sinclairql/qdosfuncs.inc
+++ b/rtl/sinclairql/qdosfuncs.inc
@@ -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'; 
diff --git a/rtl/sinclairql/sysfile.inc b/rtl/sinclairql/sysfile.inc
index ecaf72c3f6..ab8c17aa7b 100644
--- a/rtl/sinclairql/sysfile.inc
+++ b/rtl/sinclairql/sysfile.inc
@@ -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;