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

sinclairql: drop support for the BASIC loader, write Q-emuLator or XTcc compatible metadata to the executable instead. based on a patch by Marcel Kilgus in qlforum.co.uk

Browse Source 
git-svn-id: trunk@47569 -
This commit is contained in:
Károly Balogh 2020-11-25 04:39:42 +00:00
parent 3eece73a89
commit 6a88f2fc28
1 changed files with 63 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

90
compiler/systems/t_sinclairql.pas
View File

@ -35,7 +35,6 @@ type
private
Origin: DWord;
UseVLink: boolean;
ExeLength: longint;
function WriteResponseFile(isdll: boolean): boolean;
procedure SetSinclairQLInfo;
function MakeSinclairQLExe: boolean;
@ -53,6 +52,37 @@ implementation
sysutils,cutils,cfileutl,cclasses,aasmbase,
globtype,globals,systems,verbose,cscript,fmodule,i_sinclairql;
type
TQLHeader = packed record
hdr_id: array[0..17] of char;
hdr_reserved: byte;
hdr_length: byte;
hdr_access: byte;
hdr_type: byte;
hdr_data: dword;
hdr_extra: dword;
end;
TXTccData = packed record
xtcc_id: array[0..3] of char;
xtcc_data: dword;
end;
const
DefaultQLHeader: TQLHeader = (
hdr_id: ']!QDOS File Header';
hdr_reserved: 0;
hdr_length: $f;
hdr_access: 0;
hdr_type: 1;
hdr_data: 0;
hdr_extra: 0;
);
DefaultXTccData: TXTCCData = (
xtcc_id: 'XTcc';
xtcc_data: 0;
);
const
DefaultOrigin = $0;
@ -223,6 +253,10 @@ var
HeaderLine: string;
HeaderSize: longint;
code: word;
QLHeader: TQLHeader;
XTccData: TXTccData;
BinSize: longint;
DataSpace: DWord;
begin
StripStr:='';
GCSectionsStr:='';
@ -264,7 +298,10 @@ begin
and the relocation info. Here we copy the two together. (KB) }
if MakeSinclairQLExe then
begin
ExeLength:=0;
QLHeader:=DefaultQLHeader;
XTccData:=DefaultXTccData;
BinSize:=0;
bufsize:=16384;
{$push}
{$i-}
@ -284,6 +321,19 @@ begin
assign(fs,ExeName+'.'+ProgramHeaderName);
reset(fs,1);
BinSize := FileSize(fs);
{ We assume .bss size is total size indicated by linker minus emmited binary.
DataSpace size is .bss + stack space }
DataSpace := NToBE(DWord(HeaderSize - BinSize + StackSize));
{ Option: prepend QEmuLator and QPC2 v5 compatible header to EXE }
if sinclairql_metadata_format='QHDR' then
begin
QLHeader.hdr_data:=DataSpace;
blockwrite(fd, QLHeader, sizeof(QLHeader));
end;
repeat
blockread(fs,buf^,bufsize,bufread);
blockwrite(fd,buf^,bufread);
@ -300,25 +350,29 @@ begin
close(fs);
// erase(fs);
ExeLength:=FileSize(fd);
{ Option: append cross compilation data space marker, this can be picked up by
a special version of InfoZIP (compiled with -DQLZIP and option -Q) or by any
of the XTcc unpack utilities }
if sinclairql_metadata_format='XTCC' then
begin
XTccData.xtcc_data:=DataSpace;
blockwrite(fd, XTccData, sizeof(XTccData));
end;
close(fd);
{$pop}
FreeMem(buf);
if HeaderSize > ExeLength then
ExeLength:=HeaderSize;
MakeSinclairQLExe:=(code = 0) and not (ExeLength = 0);
MakeSinclairQLExe:=(code = 0) and not (BinSize = 0) and (IOResult = 0);
end;
end;
function TLinkerSinclairQL.MakeExecutable:boolean;
const
DefaultBootString = '10 $SYM=RESPR($BINSIZE):LBYTES"win1_$EXENAME",$SYM:CALL $SYM';
var
success : boolean;
bootfile : TScript;
ExeName: String;
BootStr: String;
begin
if not(cs_link_nolink in current_settings.globalswitches) then
Message1(exec_i_linking,current_module.exefilename);
@ -332,24 +386,6 @@ begin
if (success) and not(cs_link_nolink in current_settings.globalswitches) then
DeleteFile(outputexedir+Info.ResName);
if (success) then
begin
ExeName:=current_module.exefilename;
BootStr:=DefaultBootString;
Replace(BootStr,'$BINSIZE',tostr(ExeLength));
Replace(BootStr,'$EXENAME',ExeName);
Replace(ExeName,target_info.exeext,'');
Replace(BootStr,'$SYM',ExeName);
{ Write bootfile }
bootfile:=TScript.Create(outputexedir+ExeName);
bootfile.Add(BootStr);
bootfile.writetodisk;
bootfile.Free;
end;
MakeExecutable:=success; { otherwise a recursive call to link method }
end;