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

sinclairql: implemented some OS trap wrappers, to be used by the RTL

Browse Source 
git-svn-id: trunk@47348 -
This commit is contained in:
Károly Balogh 2020-11-08 20:43:01 +00:00
parent 954123deb3
commit c8d18f5ac6
4 changed files with 159 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -11902,6 +11902,9 @@ rtl/riscv64/strings.inc svneol=native#text/plain
rtl/riscv64/stringss.inc svneol=native#text/plain
rtl/sinclairql/Makefile.fpc svneol=native#text/plain
rtl/sinclairql/buildrtl.pp svneol=native#text/plain
rtl/sinclairql/qdos.inc svneol=native#text/plain
rtl/sinclairql/qdosfuncs.inc svneol=native#text/plain
rtl/sinclairql/qdosh.inc svneol=native#text/plain
rtl/sinclairql/rtl.cfg svneol=native#text/plain
rtl/sinclairql/rtldefs.inc svneol=native#text/plain
rtl/sinclairql/si_prc.pp svneol=native#text/plain

91
rtl/sinclairql/qdos.inc Normal file
View File

@ -0,0 +1,91 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2020 by Karoly Balogh
Interface QDOS OS functions used by the Sinclair QL RTL
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{$i qdosh.inc}
const
_MT_ALCHP = $18;
_MT_RECHP = $19;
function mt_alchp(size: dword; sizegot: pdword; jobid: Tjobid): pointer; assembler; nostackframe; public name '_mt_alchp';
asm
movem.l d2-d3/a2-a3,-(sp)
move.l sizegot,-(sp)
move.l jobid,d2
move.l size,d1
moveq.l #_MT_ALCHP,d0
trap #1
move.l (sp)+,d2 // sizegot ptr
tst d0
bne @quit
move.l d2,a1
beq @nosizegot
move.l d1,(a1)
@nosizegot:
move.l a0,d0
@quit:
movem.l (sp)+,d2-d3/a2-a3
end;
procedure mt_rechp(area: pointer); assembler; nostackframe; public name '_mt_rechp';
asm
movem.l d2-d3/a2-a3,-(sp)
move.l area,a0
moveq.l #_MT_RECHP,d0
trap #1
movem.l (sp)+,d2-d3/a2-a3
end;
const
_IO_SBYTE = $05;
_IO_SSTRG = $07;
function io_sbyte(chan: Tchanid; timeout: Ttimeout; c: char): longint; assembler; public name '_io_sbyte';
asm
move.l d3,-(sp)
move.w timeout,d3
clr.l d1
move.b c,d1
move.l chan,a0
moveq.l #_IO_SBYTE,d0
trap #3
move.l (sp)+,d3
end;
function io_sstrg(chan: Tchanid; timeout: Ttimeout; buf: pointer; len: smallint): smallint; assembler; public name '_io_sstrg';
asm
movem.l d2-d3,-(sp)
move.w len,d2
move.l buf,a1
move.w timeout,d3
move.l chan,a0
moveq.l #_IO_SSTRG,d0
trap #3
tst.l d0
beq @ok
cmp.w #ERR_EF,d0
beq @eof
cmp.w #ERR_NC,d0
bne @quit
@eof:
tst.w d1
beq @quit
@ok:
clr.l d0
move.w d1,d0
@quit:
movem.l (sp)+,d2-d3
end;

22
rtl/sinclairql/qdosfuncs.inc Normal file
View File

@ -0,0 +1,22 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2020 by Karoly Balogh
Headers to QDOS OS functions used by the Sinclair QL RTL
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{$i qdosh.inc}
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_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';

43
rtl/sinclairql/qdosh.inc Normal file
View File

@ -0,0 +1,43 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2020 by Karoly Balogh
Types and Constants used by QDOS OS functions in the Sinclair QL RTL
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
type
Tchanid = longint;
Tjobid = longint;
Ttimeout = smallint;
const
ERR_NC = -1; { Operation not complete }
ERR_NJ = -2; { Not a (valid) job. }
ERR_OM = -3; { Out of memory. }
ERR_OR = -4; { Out of range. }
ERR_BO = -5; { Buffer overflow. }
ERR_NO = -6; { Channel not open. }
ERR_NF = -7; { File or device not found. }
ERR_FX = -8; { File already exists. }
ERR_IU = -9; { File or device already in use. }
ERR_EF = -10; { End of file. }
ERR_DF = -11; { Drive full. }
ERR_BN = -12; { Bad device. }
ERR_TE = -13; { Transmission error. }
ERR_FF = -14; { Format failed. }
ERR_BP = -15; { Bad parameter. }
ERR_FE = -16; { File error. }
ERR_EX = -17; { Expression error. }
ERR_OV = -18; { Arithmetic overflow. }
ERR_NI = -19; { Not implemented. }
ERR_RO = -20; { Read only. }
ERR_BL = -21; { Bad line of Basic. }