662 lines
22 KiB
ObjectPascal
662 lines
22 KiB
ObjectPascal
unit RuntimeBuilder.Fasm;
|
|
|
|
interface
|
|
|
|
//{$INLINE auto}
|
|
|
|
uses
|
|
System.Classes,System.TypInfo,System.IOUtils,System.Rtti,System.Generics.Collections,Winapi.Windows,
|
|
RuntimeBuilder,FasmOnDelphi;
|
|
|
|
type
|
|
TRTBFasmCompiler=class(TRTBCompiler)
|
|
protected type
|
|
TRTBFasmSource=class(TRTBSource)
|
|
protected type
|
|
TRTBFasmModule=class(TRTBModule)
|
|
protected type
|
|
TRTBFasmFunc=class(TRTBFunc)
|
|
protected
|
|
p:Pointer;
|
|
public
|
|
constructor Create(p:Pointer);
|
|
function Call(OutType:PTypeInfo;args:TArray<TValue>;CallType:TRTBCallType=CRTBCallTypeDefault):TValue;override;
|
|
destructor Destroy;override;
|
|
end;
|
|
TRTBFasmVar=class(TRTBVar)
|
|
protected
|
|
p:pointer;
|
|
&Type:TRTBType;
|
|
procedure SetVal(Val:TValue);override;
|
|
function GetVal:TValue;override;
|
|
public
|
|
constructor Create(p:pointer;&Type:TRTBType);
|
|
destructor Destroy;override;
|
|
end;
|
|
protected
|
|
p:Pointer;
|
|
sb:NativeUInt;
|
|
funcs:TDictionary<string,NativeUInt>;
|
|
regvars:TDictionary<string,TPair<NativeUInt,PTypeInfo>>;
|
|
function GetFuntion(Name:string):TRTBFunc;override;
|
|
function GetVar(Name:string):TRTBVar;override;
|
|
public
|
|
constructor Create(p:Pointer;sb:NativeUInt;funcs:TDictionary<string,NativeUInt>;regvars:TDictionary<string,TPair<NativeUInt,PTypeInfo>>);
|
|
destructor Destroy;override;
|
|
end;
|
|
protected
|
|
libs:TStringList;
|
|
funcs:TStringList;
|
|
regvars:TList<TPair<string,PTypeInfo>>;
|
|
consts:TList<TPair<string,TValue>>;
|
|
callbacks:TList<TPair<string,TRTBCallBack>>;
|
|
FText:string;
|
|
function GetIncLibs():string;
|
|
function GetText:string;override;
|
|
procedure SetText(const S:string);override;
|
|
public
|
|
constructor Create(Compiler:TRTBFasmCompiler);
|
|
|
|
procedure LoadLib(const Name:string);override;
|
|
procedure UnLoadLib(const Name:string);override;
|
|
|
|
procedure AddNameSpace(const Name:string);override;
|
|
procedure DelNameSpace(const Name:string);override;
|
|
|
|
procedure AddType(const NameSpace,Name:string;&Type:TRTBType);override;//-
|
|
procedure DelType(const NameSpace,Name:string);override;//-
|
|
|
|
procedure AddConst(const NameSpace,Name:string;Val:TValue);override;
|
|
procedure DelConst(const NameSpace,Name:string);override;
|
|
|
|
procedure AddVariable(const NameSpace,Name:string;var Data);override;
|
|
procedure ExportVariable(const NameSpace,Name:string;var Data);override;
|
|
procedure DelVariable(const NameSpace,Name:string);override;
|
|
|
|
procedure AddCallBack(const NameSpace,Name:string;CallBack:TRTBCallBack);override;
|
|
procedure DelCallBack(const NameSpace,Name:string);override;
|
|
|
|
procedure &Register(const NameSpace,Name:string;&Type:TRTBType);override;
|
|
procedure UnRegister(const NameSpace,Name:string);override;
|
|
procedure RegisterFunction(const NameSpace,Name:string);override;
|
|
procedure UnRegisterFunction(const NameSpace,Name:string);override;
|
|
|
|
function Compilate:TRTBModule;override;
|
|
destructor Destroy;override;
|
|
end;
|
|
public
|
|
CompilerMem:NativeUInt;
|
|
MaxSteps:word;
|
|
constructor Create(FasmPath:String=FasmPath;AsDll:boolean=false);
|
|
function GenNewSrc():TRTBSource;override;
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses System.SysUtils;
|
|
|
|
function CallBackCall(callbacks:TList<TPair<string,TRTBCallBack>>;n:NativeUInt;p:pointer):pointer;stdcall;
|
|
begin
|
|
with callbacks[n].Value([p])do
|
|
begin
|
|
Result:=GetMemory(DataSize);
|
|
ExtractRawData(Result);
|
|
end;
|
|
end;
|
|
|
|
constructor TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.TRTBFasmFunc.Create(p:Pointer);
|
|
begin
|
|
inherited Create();
|
|
Self.p:=p;
|
|
end;
|
|
|
|
function TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.TRTBFasmFunc.Call(OutType:PTypeInfo;args:TArray<TValue>;CallType:TRTBCallType=CRTBCallTypeDefault):TValue;
|
|
begin
|
|
{$IFDEF CPUX64}
|
|
Result:=Invoke(p,args,ccReg,OutType);
|
|
{$ELSE}
|
|
case CallType of
|
|
CRTBCallTypeRegister:Result:=Invoke(p,args,ccReg,OutType);
|
|
CRTBCallTypeStdCall:Result:=Invoke(p,args,ccStdCall,OutType);
|
|
CRTBCallTypeCdecl:Result:=Invoke(p,args,ccCdecl,OutType);
|
|
CRTBCallTypePascal:Result:=Invoke(p,args,ccPascal,OutType);
|
|
CRTBCallTypeSafeCall:Result:=Invoke(p,args,ccSafeCall,OutType);
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
destructor TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.TRTBFasmFunc.Destroy;
|
|
begin
|
|
p:=nil;
|
|
end;
|
|
|
|
procedure TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.TRTBFasmVar.SetVal(Val:TValue);
|
|
begin
|
|
if Val.TypeInfo=&Type then
|
|
Val.ExtractRawData(p);
|
|
end;
|
|
|
|
function TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.TRTBFasmVar.GetVal:TValue;
|
|
begin
|
|
TValue.Make(p,&Type,Result);
|
|
end;
|
|
|
|
constructor TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.TRTBFasmVar.Create(p:pointer;&Type:TRTBType);
|
|
begin
|
|
Self.p:=p;
|
|
Self.&Type:=&Type;
|
|
end;
|
|
|
|
destructor TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.TRTBFasmVar.Destroy;
|
|
begin
|
|
p:=nil;
|
|
&Type:=nil;
|
|
end;
|
|
|
|
function TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.GetFuntion(Name:string):TRTBFunc;
|
|
begin
|
|
Result:=TRTBFasmFunc.Create(PPointer(NativeUInt(funcs.Items[Name])+NativeUInt(p))^);
|
|
end;
|
|
|
|
function TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.GetVar(Name:string):TRTBVar;
|
|
begin
|
|
Result:=TRTBFasmVar.Create(PPointer(NativeUInt(regvars.Items[Name].Key)+NativeUInt(p))^,regvars.Items[Name].Value)
|
|
end;
|
|
|
|
constructor TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.Create(p:Pointer;sb:NativeUInt;funcs:TDictionary<string,NativeUInt>;regvars:TDictionary<string,TPair<NativeUInt,PTypeInfo>>);
|
|
begin
|
|
Self.p:=p;
|
|
Self.sb:=sb;
|
|
Self.funcs:=funcs;
|
|
Self.regvars:=regvars;
|
|
end;
|
|
|
|
destructor TRTBFasmCompiler.TRTBFasmSource.TRTBFasmModule.Destroy;
|
|
begin
|
|
VirtualFree(p,sb,MEM_RELEASE);
|
|
end;
|
|
|
|
function TRTBFasmCompiler.TRTBFasmSource.GetIncLibs():string;
|
|
var
|
|
i:integer;
|
|
begin
|
|
Result:='';
|
|
for i:=0 to libs.count-1 do
|
|
Result:=Result+sLineBreak+'include '+#39+libs.Strings[i]+#39;
|
|
end;
|
|
|
|
function TRTBFasmCompiler.TRTBFasmSource.GetText:string;
|
|
begin
|
|
Result:=FText;
|
|
end;
|
|
|
|
procedure TRTBFasmCompiler.TRTBFasmSource.SetText(const S:string);
|
|
begin
|
|
FText:=S;
|
|
end;
|
|
|
|
constructor TRTBFasmCompiler.TRTBFasmSource.Create(Compiler:TRTBFasmCompiler);
|
|
begin
|
|
inherited Create(Compiler);
|
|
FText:='';
|
|
libs:=TStringList.Create;
|
|
funcs:=TStringList.Create;
|
|
regvars:=TList<TPair<string,PTypeInfo>>.Create;
|
|
consts:=TList<TPair<string,TValue>>.Create;
|
|
callbacks:=TList<TPair<string,TRTBCallBack>>.Create;
|
|
end;
|
|
|
|
procedure TRTBFasmCompiler.TRTBFasmSource.LoadLib(const Name:string);
|
|
begin
|
|
libs.Add(Name);
|
|
end;
|
|
|
|
procedure TRTBFasmCompiler.TRTBFasmSource.UnLoadLib(const Name:string);
|
|
begin
|
|
with libs do
|
|
Delete(IndexOf(Name));
|
|
end;
|
|
|
|
procedure TRTBFasmCompiler.TRTBFasmSource.AddNameSpace(const Name:string);
|
|
begin
|
|
end;
|
|
|
|
procedure TRTBFasmCompiler.TRTBFasmSource.DelNameSpace(const Name:string);
|
|
label
|
|
funcscontinue,regvarscontinue,constscontinue;
|
|
var
|
|
i,i0:NativeUInt;
|
|
tName:string;
|
|
begin
|
|
tName:=Name+'.';
|
|
i:=0;
|
|
while i<funcs.Count do
|
|
begin
|
|
for i0:=1 to length(tName) do
|
|
if funcs.Strings[i][i0]=tName[i0]then
|
|
goto funcscontinue;
|
|
funcs.Delete(i);
|
|
inc(i);
|
|
funcscontinue:
|
|
end;
|
|
i:=0;
|
|
while i<regvars.Count do
|
|
begin
|
|
for i0:=1 to length(tName) do
|
|
if regvars.Items[i].Key[i0]=tName[i0]then
|
|
goto regvarscontinue;
|
|
regvars.Delete(i);
|
|
inc(i);
|
|
regvarscontinue:
|
|
end;
|
|
i:=0;
|
|
while i<consts.Count do
|
|
begin
|
|
for i0:=1 to length(tName) do
|
|
if consts.Items[i].Key[i0]=tName[i0]then
|
|
goto constscontinue;
|
|
consts.Delete(i);
|
|
inc(i);
|
|
constscontinue:
|
|
end;
|
|
end;
|
|
|
|
procedure TRTBFasmCompiler.TRTBFasmSource.AddType(const NameSpace,Name:string;&Type:TRTBType);
|
|
begin
|
|
end;
|
|
|
|
procedure TRTBFasmCompiler.TRTBFasmSource.DelType(const NameSpace,Name:string);
|
|
begin
|
|
end;
|
|
|
|
procedure TRTBFasmCompiler.TRTBFasmSource.AddConst(const NameSpace,Name:string;Val:TValue);
|
|
begin
|
|
if NameSpace<>'' then
|
|
consts.Add(TPair<string,TValue>.Create(NameSpace+'.'+Name,Val))
|
|
else
|
|
consts.Add(TPair<string,TValue>.Create(Name,Val));
|
|
end;
|
|
|
|
procedure TRTBFasmCompiler.TRTBFasmSource.DelConst(const NameSpace,Name:string);
|
|
var
|
|
i:NativeUInt;
|
|
begin
|
|
if consts.Count<>0 then
|
|
for i:=0 to consts.Count-1 do
|
|
if(consts.Items[i].Key=NameSpace+'.'+Name)or(consts.Items[i].Key=Name)then
|
|
begin
|
|
consts.Delete(i);
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
procedure TRTBFasmCompiler.TRTBFasmSource.AddVariable(const NameSpace,Name:string;var Data);
|
|
begin
|
|
if NameSpace<>'' then
|
|
consts.Add(TPair<string,TValue>.Create(NameSpace+'.'+Name,addr(Data)))
|
|
else
|
|
consts.Add(TPair<string,TValue>.Create(Name,addr(Data)));
|
|
end;
|
|
|
|
procedure TRTBFasmCompiler.TRTBFasmSource.ExportVariable(const NameSpace,Name:string;var Data);
|
|
begin
|
|
if NameSpace<>'' then
|
|
consts.Add(TPair<string,TValue>.Create(NameSpace+'.'+Name,Addr(Data)))
|
|
else
|
|
consts.Add(TPair<string,TValue>.Create(Name,Addr(Data)));
|
|
end;
|
|
|
|
procedure TRTBFasmCompiler.TRTBFasmSource.DelVariable(const NameSpace,Name:string);
|
|
begin
|
|
DelConst(NameSpace,Name);
|
|
end;
|
|
|
|
procedure TRTBFasmCompiler.TRTBFasmSource.AddCallBack(const NameSpace,Name:string;CallBack:TRTBCallBack);
|
|
begin
|
|
if NameSpace<>'' then
|
|
callbacks.Add(TPair<string,TRTBCallBack>.Create(NameSpace+'.'+Name,CallBack))
|
|
else
|
|
callbacks.Add(TPair<string,TRTBCallBack>.Create(Name,CallBack));
|
|
end;
|
|
|
|
procedure TRTBFasmCompiler.TRTBFasmSource.DelCallBack(const NameSpace,Name:string);
|
|
var
|
|
i:NativeUInt;
|
|
begin
|
|
if callbacks.Count<>0 then
|
|
for i:=0 to callbacks.Count-1 do
|
|
if(callbacks.Items[i].Key=NameSpace+'.'+Name)or(callbacks.Items[i].Key=Name)then
|
|
begin
|
|
callbacks.Delete(i);
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
procedure TRTBFasmCompiler.TRTBFasmSource.&Register(const NameSpace,Name:string;&Type:TRTBType);
|
|
begin
|
|
if NameSpace<>'' then
|
|
regvars.Add(TPair<string,PTypeInfo>.Create(NameSpace+'.'+Name,&Type))
|
|
else
|
|
regvars.Add(TPair<string,PTypeInfo>.Create(Name,&Type));
|
|
end;
|
|
|
|
procedure TRTBFasmCompiler.TRTBFasmSource.UnRegister(const NameSpace,Name:string);
|
|
var
|
|
i:NativeUInt;
|
|
begin
|
|
if regvars.Count<>0 then
|
|
for i:=0 to regvars.Count-1 do
|
|
if(regvars.Items[i].Key=Name)or(regvars.Items[i].Key=NameSpace+'.'+Name) then
|
|
begin
|
|
regvars.Delete(i);
|
|
Break;
|
|
end;
|
|
end;
|
|
|
|
procedure TRTBFasmCompiler.TRTBFasmSource.RegisterFunction(const NameSpace,Name:string);
|
|
begin
|
|
if NameSpace<>'' then
|
|
funcs.Add(NameSpace+'.'+Name)
|
|
else
|
|
funcs.Add(Name);
|
|
end;
|
|
|
|
procedure TRTBFasmCompiler.TRTBFasmSource.UnRegisterFunction(const NameSpace,Name:string);
|
|
begin
|
|
with funcs do
|
|
begin
|
|
Delete(IndexOf(NameSpace+'.'+Name));
|
|
Delete(IndexOf(Name));
|
|
end;
|
|
end;
|
|
|
|
function TRTBFasmCompiler.TRTBFasmSource.Compilate:TRTBModule;
|
|
procedure VarParse(key:string;Value:TValue;var PreDecl:string;var base:NativeUInt);
|
|
var
|
|
i:NativeUInt;
|
|
p0:PByte;
|
|
rfield:TRttiField;
|
|
rmetod:TRttiMethod;
|
|
begin
|
|
if Value.IsType<AnsiString> or Value.IsType<RawByteString> or Value.IsType<UTF8String> then
|
|
begin
|
|
PreDecl:=PreDecl+Key+' db '+#39+Value.AsType<AnsiString>+#39+',0'+sLineBreak;
|
|
inc(base,length(Value.AsType<AnsiString>));
|
|
end
|
|
else if Value.IsType<ShortString> then
|
|
begin
|
|
PreDecl:=PreDecl+Key+' db '+#39+Value.AsType<ShortString>+#39+',0'+sLineBreak;
|
|
inc(base,length(Value.AsType<ShortString>));
|
|
end
|
|
else if Value.IsType<WideString> then
|
|
begin
|
|
PreDecl:=PreDecl+Key+' db ';
|
|
p0:=Pointer(PWideChar(Value.AsType<WideString>));
|
|
for i:={$IFDEF NEXTGEN}0{$ELSE}1{$ENDIF} to length(Value.AsType<WideString>){$IFDEF NEXTGEN}-1{$ENDIF} do
|
|
begin
|
|
PreDecl:=PreDecl+inttostr(p0^)+',';
|
|
inc(p0);
|
|
PreDecl:=PreDecl+inttostr(p0^)+',';
|
|
inc(p0);
|
|
end;
|
|
PreDecl:=PreDecl+'0,0'+sLineBreak;
|
|
inc(base,length(Value.AsType<WideString>)*2);
|
|
end
|
|
else if Value.IsType<UCS4String> then
|
|
begin
|
|
PreDecl:=PreDecl+Key+' db ';
|
|
p0:=Pointer(PWideChar(Value.AsType<UCS4String>));
|
|
for i:={$IFDEF NEXTGEN}0{$ELSE}1{$ENDIF} to length(Value.AsType<UCS4String>){$IFDEF NEXTGEN}-1{$ENDIF} do
|
|
begin
|
|
PreDecl:=PreDecl+inttostr(p0^)+',';
|
|
inc(p0);
|
|
PreDecl:=PreDecl+inttostr(p0^)+',';
|
|
inc(p0);
|
|
PreDecl:=PreDecl+inttostr(p0^)+',';
|
|
inc(p0);
|
|
PreDecl:=PreDecl+inttostr(p0^)+',';
|
|
inc(p0);
|
|
end;
|
|
PreDecl:=PreDecl+'0,0,0,0'+sLineBreak;
|
|
inc(base,length(Value.AsType<UCS4String>)*4);
|
|
end
|
|
else if Value.IsOrdinal then
|
|
begin
|
|
case Value.DataSize of
|
|
1:PreDecl:=PreDecl+Key+' db '+Value.AsOrdinal.ToString+sLineBreak;
|
|
2:PreDecl:=PreDecl+Key+' dw '+Value.AsOrdinal.ToString+sLineBreak;
|
|
4:PreDecl:=PreDecl+Key+' dd '+Value.AsOrdinal.ToString+sLineBreak;
|
|
8:PreDecl:=PreDecl+Key+' dq '+Value.AsOrdinal.ToString+sLineBreak;
|
|
end;
|
|
inc(base,Value.DataSize);
|
|
end
|
|
else if Value.Kind=tkFloat then
|
|
begin
|
|
if Value.IsType<Single> then
|
|
PreDecl:=PreDecl+Key+' dd '+FloatToStrF(Value.AsType<Single>,ffFixed,1000,1000)+sLineBreak
|
|
else if Value.IsType<Double> then
|
|
PreDecl:=PreDecl+Key+' dq '+FloatToStrF(Value.AsType<Double>,ffFixed,1000,1000)+sLineBreak
|
|
else if Value.IsType<Extended> then
|
|
PreDecl:=PreDecl+Key+{$IF 8=SizeOf(Extended)}' dq '{$ELSEIF 10=SizeOf(Extended)}' dt '{$ELSE}' ddq '{$IFEND}+FloatToStrF(Value.AsType<Extended>,ffFixed,1000,1000)+sLineBreak
|
|
else if Value.IsType<Real> then
|
|
PreDecl:=PreDecl+Key+' dq '+FloatToStrF(Value.AsType<Real>,ffFixed,1000,1000)+sLineBreak
|
|
else if Value.IsType<Real48> then
|
|
PreDecl:=PreDecl+Key+' df '+FloatToStrF(Value.AsType<Real48>,ffFixed,1000,1000)+sLineBreak
|
|
else if Value.IsType<Comp> then
|
|
PreDecl:=PreDecl+Key+' dq '+FloatToStrF(Value.AsType<Comp>,ffFixed,1000,1000)+sLineBreak
|
|
else if Value.IsType<Currency> then
|
|
PreDecl:=PreDecl+Key+' dq '+FloatToStrF(Value.AsType<Currency>,ffFixed,1000,1000)+sLineBreak
|
|
else
|
|
PreDecl:=PreDecl+Key+' dd 0.0'+sLineBreak;
|
|
end
|
|
else if Value.Kind=tkPointer then
|
|
begin
|
|
case SizeOf(pointer) of
|
|
2:PreDecl:=PreDecl+Key+' dw '+NativeUInt(Value.AsType<Pointer>).ToString+sLineBreak;
|
|
4:PreDecl:=PreDecl+Key+' dd '+NativeUInt(Value.AsType<Pointer>).ToString+sLineBreak;
|
|
8:PreDecl:=PreDecl+Key+' dq '+NativeUInt(Value.AsType<Pointer>).ToString+sLineBreak;
|
|
end;
|
|
inc(base,SizeOf(pointer));
|
|
end
|
|
else if Value.IsArray then
|
|
begin
|
|
if Value.GetArrayLength=0 then
|
|
begin
|
|
PreDecl:=PreDecl+Key+' equ 0'+sLineBreak;
|
|
end
|
|
else
|
|
begin
|
|
PreDecl:=PreDecl+Key+':'+sLineBreak;
|
|
for i:=0 to Value.GetArrayLength-1 do
|
|
VarParse(key+'.i'+i.ToString,Value.GetArrayElement(i),PreDecl,Base);
|
|
end;
|
|
end
|
|
else if Value.Kind=tkRecord or Value.IsClass then
|
|
begin
|
|
PreDecl:=PreDecl+Key+':'+sLineBreak;
|
|
for rfield in TRTTIContext.Create.GetType(Value.TypeInfo).GetFields do
|
|
VarParse(key+'.'+rfield.Name,rfield.GetValue(@Value),PreDecl,base);
|
|
for rmetod in TRTTIContext.Create.GetType(Value.TypeInfo).GetMethods do
|
|
begin
|
|
PreDecl:=PreDecl+key+'.'+rmetod.Name+' dd '+NativeUInt(rmetod.CodeAddress).ToString;
|
|
case SizeOf(pointer) of
|
|
2:PreDecl:=PreDecl+Key+' dw '+NativeUInt(Value.AsType<Pointer>).ToString+sLineBreak;
|
|
4:PreDecl:=PreDecl+Key+' dd '+NativeUInt(Value.AsType<Pointer>).ToString+sLineBreak;
|
|
8:PreDecl:=PreDecl+Key+' dq '+NativeUInt(Value.AsType<Pointer>).ToString+sLineBreak;
|
|
end;
|
|
inc(base,SizeOf(pointer));
|
|
end;
|
|
end
|
|
else //if Value.Kind=tkUnknown then
|
|
PreDecl:=PreDecl+Key+': times '+ Value.DataSize.ToString+' db 0'+sLineBreak;
|
|
end;
|
|
procedure ConstParse(key:string;value:TValue;var PreDecl:string;var base:NativeUInt);
|
|
var
|
|
i:NativeUInt;
|
|
p0:PByte;
|
|
begin
|
|
if Value.IsType<AnsiString> or Value.IsType<RawByteString> or Value.IsType<UTF8String> then
|
|
begin
|
|
PreDecl:=PreDecl+Key+' db '+#39+Value.AsType<AnsiString>+#39+',0'+sLineBreak;
|
|
inc(base,length(Value.AsType<AnsiString>));
|
|
end
|
|
else if Value.IsType<ShortString> then
|
|
begin
|
|
PreDecl:=PreDecl+Key+' db '+#39+Value.AsType<ShortString>+#39+',0'+sLineBreak;
|
|
inc(base,length(Value.AsType<ShortString>));
|
|
end
|
|
else if Value.IsType<WideString> then
|
|
begin
|
|
PreDecl:=PreDecl+Key+' db ';
|
|
p0:=Pointer(PWideChar(Value.AsType<WideString>));
|
|
for i:={$IFDEF NEXTGEN}0{$ELSE}1{$ENDIF} to length(Value.AsType<WideString>){$IFDEF NEXTGEN}-1{$ENDIF} do
|
|
begin
|
|
PreDecl:=PreDecl+inttostr(p0^)+',';
|
|
inc(p0);
|
|
PreDecl:=PreDecl+inttostr(p0^)+',';
|
|
inc(p0);
|
|
end;
|
|
PreDecl:=PreDecl+'0,0'+sLineBreak;
|
|
inc(base,length(Value.AsType<WideString>)*2);
|
|
end
|
|
else if Value.IsType<UCS4String> then
|
|
begin
|
|
PreDecl:=PreDecl+Key+' db ';
|
|
p0:=Pointer(PWideChar(Value.AsType<UCS4String>));
|
|
for i:={$IFDEF NEXTGEN}0{$ELSE}1{$ENDIF} to length(Value.AsType<UCS4String>){$IFDEF NEXTGEN}-1{$ENDIF} do
|
|
begin
|
|
PreDecl:=PreDecl+inttostr(p0^)+',';
|
|
inc(p0);
|
|
PreDecl:=PreDecl+inttostr(p0^)+',';
|
|
inc(p0);
|
|
PreDecl:=PreDecl+inttostr(p0^)+',';
|
|
inc(p0);
|
|
PreDecl:=PreDecl+inttostr(p0^)+',';
|
|
inc(p0);
|
|
end;
|
|
PreDecl:=PreDecl+'0,0,0,0'+sLineBreak;
|
|
inc(base,length(Value.AsType<UCS4String>)*4);
|
|
end
|
|
else if Value.IsOrdinal then
|
|
PreDecl:=PreDecl+Key+' equ '+Value.AsOrdinal.ToString+sLineBreak
|
|
else if Value.Kind=tkFloat then
|
|
begin
|
|
if Value.IsType<Single> then
|
|
PreDecl:=PreDecl+Key+' equ '+FloatToStrF(Value.AsType<Single>,ffFixed,1000,1000)+sLineBreak
|
|
else if Value.IsType<Double> then
|
|
PreDecl:=PreDecl+Key+' equ '+FloatToStrF(Value.AsType<Double>,ffFixed,1000,1000)+sLineBreak
|
|
else if Value.IsType<Extended> then
|
|
PreDecl:=PreDecl+Key+' equ '+FloatToStrF(Value.AsType<Extended>,ffFixed,1000,1000)+sLineBreak
|
|
else if Value.IsType<Real> then
|
|
PreDecl:=PreDecl+Key+' equ '+FloatToStrF(Value.AsType<Real>,ffFixed,1000,1000)+sLineBreak
|
|
else if Value.IsType<Real48> then
|
|
PreDecl:=PreDecl+Key+' equ '+FloatToStrF(Value.AsType<Real48>,ffFixed,1000,1000)+sLineBreak
|
|
else if Value.IsType<Comp> then
|
|
PreDecl:=PreDecl+Key+' equ '+FloatToStrF(Value.AsType<Comp>,ffFixed,1000,1000)+sLineBreak
|
|
else if Value.IsType<Currency> then
|
|
PreDecl:=PreDecl+Key+' equ '+FloatToStrF(Value.AsType<Currency>,ffFixed,1000,1000)+sLineBreak
|
|
else
|
|
PreDecl:=PreDecl+Key+' equ 0.0'+sLineBreak;
|
|
end
|
|
else if Value.Kind=tkPointer then
|
|
PreDecl:=PreDecl+Key+' equ '+NativeUInt(Value.AsType<Pointer>).ToString+sLineBreak
|
|
else if Value.IsArray then
|
|
begin
|
|
if Value.GetArrayLength=0 then
|
|
begin
|
|
PreDecl:=PreDecl+Key+' equ 0'+sLineBreak;
|
|
end
|
|
else
|
|
begin
|
|
PreDecl:=PreDecl+Key+':'+sLineBreak;
|
|
for i:=0 to Value.GetArrayLength-1 do
|
|
VarParse(key+'.i'+i.ToString,Value.GetArrayElement(i),PreDecl,Base);
|
|
end;
|
|
end
|
|
else
|
|
VarParse(key,Value,PreDecl,Base);
|
|
end;
|
|
var
|
|
pointerDecl,PreDecl:string;
|
|
Res:TFasmResult;
|
|
i,base,sb:NativeUInt;
|
|
FuncDict:TDictionary<string,NativeUInt>;
|
|
RegVarDict:TDictionary<string,TPair<NativeUInt,PTypeInfo>>;
|
|
p:pointer;
|
|
begin
|
|
sb:=(Compiler as TRTBFasmCompiler).CompilerMem;
|
|
p:=VirtualAlloc(nil,sb,MEM_COMMIT,PAGE_EXECUTE_READWRITE);
|
|
case SizeOf(pointer)of
|
|
2:pointerDecl:='dw ';
|
|
4:pointerDecl:='dd ';
|
|
8:pointerDecl:='dq ';
|
|
end;
|
|
PreDecl:='use32'+sLineBreak;
|
|
FuncDict:=TDictionary<string,NativeUInt>.Create();
|
|
base:=0;
|
|
with funcs do
|
|
if Count<>0 then
|
|
for i:=0 to Count-1 do
|
|
begin
|
|
PreDecl:=PreDecl+pointerDecl+Strings[i]+sLineBreak;
|
|
FuncDict.Add(Strings[i],base);
|
|
inc(base,SizeOf(pointer));
|
|
end;
|
|
RegVarDict:=TDictionary<string,TPair<NativeUInt,PTypeInfo>>.Create();
|
|
with regvars do
|
|
if Count<>0 then
|
|
for i:=0 to Count-1 do
|
|
begin
|
|
PreDecl:=PreDecl+pointerDecl+Items[i].Key+sLineBreak;
|
|
RegVarDict.Add(Items[i].Key,TPair<NativeUInt,PTypeInfo>.Create(base,Items[i].Value));
|
|
inc(base,SizeOf(pointer));
|
|
end;
|
|
with consts do
|
|
if Count<>0 then
|
|
for i:=0 to Count-1 do
|
|
with Items[i] do
|
|
ConstParse(Key,Value,PreDecl,base);
|
|
if callbacks.Count<>0 then
|
|
for i:=0 to callbacks.Count-1 do
|
|
PreDecl:=PreDecl+callbacks[i].Key+':'+sLineBreak+
|
|
{$IFDEF CPU32BITS}'pop eax'{$ELSE}'pop rax'{$ENDIF}+sLineBreak+
|
|
{$IFDEF CPU32BITS}'push dword '{$ELSE}'push qword '{$ENDIF}+i.ToString+sLineBreak+
|
|
{$IFDEF CPU32BITS}'push dword '{$ELSE}'push qword '{$ENDIF}+NativeUint(pointer(callbacks)).ToString+sLineBreak+
|
|
{$IFDEF CPU32BITS}'push eax'{$ELSE}'push rax'{$ENDIF}+sLineBreak+
|
|
{$IFDEF CPU32BITS}'jmp dword '{$ELSE}'jmp qword '{$ENDIF}+NativeUint(@CallBackCall).ToString+sLineBreak;
|
|
Res:=FasmAssemble('org '+NativeUInt(p).ToString+sLineBreak+PreDecl+Text+GetIncLibs,sb,(Compiler as TRTBFasmCompiler).MaxSteps);
|
|
if Res.Error<>FASM_OK then
|
|
begin
|
|
VirtualFree(p,sb,MEM_RELEASE);
|
|
raise Exception.Create(Res.OutStr);
|
|
end;
|
|
VirtualAlloc(p,Res.sb,MEM_COMMIT,PAGE_EXECUTE_READWRITE);
|
|
CopyMemory(p,Res.OutData,Res.sb);
|
|
FreeMem(Res.OutData);
|
|
Result:=TRTBFasmModule.Create(p,Res.sb,FuncDict,RegVarDict);
|
|
p:=nil;
|
|
end;
|
|
|
|
destructor TRTBFasmCompiler.TRTBFasmSource.Destroy;
|
|
begin
|
|
FreeAndNil(libs);
|
|
FreeAndNil(funcs);
|
|
FreeAndNil(regvars);
|
|
FreeAndNil(consts);
|
|
end;
|
|
|
|
constructor TRTBFasmCompiler.Create(FasmPath:String=FasmPath;AsDll:boolean=false);
|
|
begin
|
|
inherited Create();
|
|
CompilerMem:=1024*1024*16;
|
|
MaxSteps:=65535;
|
|
OpenFASM(FasmPath,AsDll);
|
|
end;
|
|
|
|
function TRTBFasmCompiler.GenNewSrc():TRTBSource;
|
|
begin
|
|
Result:=TRTBFasmSource.Create(Self);
|
|
end;
|
|
|
|
end.
|