paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-20 18:29:28 +02:00
Code Issues Packages Projects Releases Wiki Activity

sinclairql: implemented startup code, including binary relocation and stack allocation

Browse Source 
git-svn-id: trunk@47349 -
This commit is contained in:
Károly Balogh 2020-11-08 20:48:04 +00:00
parent c8d18f5ac6
commit b425c97fce
1 changed files with 60 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
rtl/sinclairql/si_prc.pp
View File

@ -19,23 +19,79 @@ interface
implementation
{$i qdosfuncs.inc}
var
procdesc: PPD; public name '__base';
stacktop: pointer;
stackorig: pointer;
setjmpbuf: jmp_buf;
stklen: longint; external name '__stklen';
binstart: pointer; external name '_stext';
binend: pointer; external name '_etext';
procedure PascalMain; external name 'PASCALMAIN';
{ this function must be the first in this unit which contains code }
{$OPTIMIZATION OFF}
procedure _FPC_proc_start(pd: PPD); cdecl; public name '_start';
function _FPC_proc_start: longint; cdecl; public name '_start';
var
newstack: pointer;
begin
_FPC_proc_start:=0;
asm
move.l d7,-(sp)
{ relocation code }
{ get our actual position in RAM }
lea.l binstart(pc),a0
move.l a0,d0
{ get an offset to the end of the binary. this depends on the
fact that at this point the binary is not relocated yet }
lea.l binend,a1
add.l d0,a1
{ first item in the relocation table is the number of relocs }
move.l (a1),d7
beq @noreloc
{ zero out the number of relocs in RAM, so if our code is
called again, without reload, it won't relocate itself twice }
move.l #0,(a1)+
@relocloop:
{ we read the offsets and relocate them }
move.l (a1)+,d1
add.l d0,(a0,d1)
subq.l #1,d7
bne @relocloop
@noreloc:
move.l (sp)+,d7
{ save the original stack pointer }
move.l a7,stackorig
end;
newstack:=mt_alchp(stklen,nil,-1);
if not assigned(newstack) then
_FPC_proc_start:=ERR_OM
else
begin
asm
move.l newstack,sp
end;
if setjmp(setjmpbuf) = 0 then
PascalMain;
asm
move.l stackorig,sp
end;
mt_rechp(newstack);
end;
end;
procedure _FPC_proc_halt(_ExitCode: longint); cdecl; public name '_haltproc';
procedure _FPC_proc_halt(_ExitCode: longint); public name '_haltproc';
begin
longjmp(setjmpbuf,1);
end;