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

sinclairql: add a few more QDOS function wrappers which are useful at early stage

Browse Source 
git-svn-id: trunk@47420 -
This commit is contained in:
Károly Balogh 2020-11-15 04:55:42 +00:00
parent e5d2c1a980
commit 157e8792c5
3 changed files with 115 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
rtl/sinclairql/qdos.inc
View File

@ -16,9 +16,25 @@
{$i qdosh.inc}
const
_MT_INF = $00;
_MT_ALCHP = $18;
_MT_RECHP = $19;
function mt_inf(sys_vars: ppchar; ver_ascii: plongint): Tjobid; assembler; nostackframe; public name '_mt_inf';
asm
move.l d2,-(sp)
move.l sys_vars,-(sp)
move.l ver_ascii,-(sp)
moveq.l #_MT_INF,d0
trap #1
move.l (sp)+,a1
move.l d2,(a1) { ver_ascii }
move.l (sp)+,a1
move.l a0,(a1) { sys_vars }
move.l (sp)+,d2
move.l d1,d0 { jobid }
end;
function mt_alchp(size: dword; sizegot: pdword; jobid: Tjobid): pointer; assembler; nostackframe; public name '_mt_alchp';
asm
movem.l d2-d3/a2-a3,-(sp)
@ -49,6 +65,47 @@ asm
end;
const
_IO_OPEN = $01;
_IO_CLOSE = $02;
function io_open_qlstr(name_qlstr: pointer; mode: longint): Tchanid; assembler; nostackframe; public name '_io_open_qlstr';
asm
movem.l d2-d3,-(sp)
move.l name_qlstr,a0
moveq.l #-1,d1
move.l mode,d3
moveq.l #_IO_OPEN,d0
trap #2
bne @quit
move.l a0,d0
@quit:
movem.l (sp)+,d2-d3
end;
function io_open(name: pchar; mode: longint): Tchanid; public name '_io_open';
var
len: longint;
name_qlstr: array[0..63] of char;
begin
len:=length(name);
if len > length(name_qlstr)-2 then
len:=length(name_qlstr)-2;
PWord(@name_qlstr)[0]:=len;
Move(name^,name_qlstr[2],len);
result:=io_open_qlstr(@name_qlstr,mode);
end;
function io_close(chan: Tchanid): longint; assembler; nostackframe; public name '_io_close';
asm
move.l chan,a0
moveq.l #_IO_CLOSE,d0
trap #2
end;
const
_IO_SBYTE = $05;
_IO_SSTRG = $07;
@ -89,3 +146,32 @@ asm
@quit:
movem.l (sp)+,d2-d3
end;
const
_UT_CON = $c6;
_UT_SCR = $c8;
function ut_con(params: PConScrParams): Tchanid; assembler; nostackframe; public name '_ut_con';
asm
movem.l d2-d3/a2-a3,-(sp)
move.l params,a1
move.w _UT_CON,a2
jsr (a2)
bne @quit
move.l a0,d0
@quit:
movem.l (sp)+,d2-d3/a2-a3
end;
function ut_scr(params: PConScrParams): Tchanid; assembler; nostackframe; public name '_ut_scr';
asm
movem.l d2-d3/a2-a3,-(sp)
move.l params,a1
move.w _UT_SCR,a2
jsr (a2)
bne @quit
move.l a0,d0
@quit:
movem.l (sp)+,d2-d3/a2-a3
end;

9
rtl/sinclairql/qdosfuncs.inc
View File

@ -15,8 +15,17 @@
{$i qdosh.inc}
function mt_inf(sys_vars: ppchar; ver_ascii: plongint): Tjobid; external name '_mt_inf';
function mt_alchp(size: dword; sizegot: pdword; jobid: Tjobid): pointer; external name '_mt_alchp';
procedure mt_rechp(area: pointer); external name '_mt_rechp';
function io_open_qlstr(name_qlstr: pointer; mode: longint): Tchanid; external name '_io_open_qlstr';
function io_open(name: pchar; mode: longint): Tchanid; external name '_io_open';
function io_close(chan: Tchanid): longint; external name '_io_close';
function io_sbyte(chan: Tchanid; timeout: Ttimeout; c: char): longint; external name '_io_sbyte';
function io_sstrg(chan: Tchanid; timeout: Ttimeout; buf: pointer; len: smallint): smallint; external name '_io_sstrg';
function ut_con(params: PConScrParams): Tchanid; external name '_ut_con';
function ut_scr(params: PConScrParams): Tchanid; external name '_ut_scr';

21
rtl/sinclairql/qdosh.inc
View File

@ -39,5 +39,24 @@ const
ERR_EX = -17; { Expression error. }
ERR_OV = -18; { Arithmetic overflow. }
ERR_NI = -19; { Not implemented. }
ERR_RO = -20; { Read only. }
ERR_RO = -20; { Read only. }
ERR_BL = -21; { Bad line of Basic. }
const
Q_OPEN = 0;
Q_OPEN_IN = 1;
Q_OPEN_NEW = 2;
Q_OPEN_OVER = 3; { Not available on microdrives. }
Q_OPEN_DIR = 4;
type
TConScrParams = record
bordercolor: byte;
bordersize: byte;
papercolor: byte;
inkcolor: byte;
width,height: word;
x,y: word;
end;
PConScrParams = ^TConScrParams;