1883 lines
52 KiB
ObjectPascal
1883 lines
52 KiB
ObjectPascal
////////////////////////////////////////////////////////////////////////////
|
|
// PaxCompiler
|
|
// Site: http://www.paxcompiler.com
|
|
// Author: Alexander Baranovsky (paxscript@gmail.com)
|
|
// ========================================================================
|
|
// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved.
|
|
// Code Version: 4.2
|
|
// ========================================================================
|
|
// Unit: PAXCOMP_IMPORT.pas
|
|
// ========================================================================
|
|
////////////////////////////////////////////////////////////////////////////
|
|
|
|
{$I PaxCompiler.def}
|
|
unit PAXCOMP_IMPORT;
|
|
interface
|
|
uses {$I uses.def}
|
|
SysUtils,
|
|
Classes,
|
|
PAXCOMP_SYS,
|
|
PAXCOMP_CONSTANTS,
|
|
PAXCOMP_KERNEL,
|
|
PAXCOMP_BYTECODE,
|
|
PAXCOMP_STDLIB,
|
|
PAXCOMP_BASESYMBOL_TABLE,
|
|
PAXCOMP_SYMBOL_REC,
|
|
PAXCOMP_SYMBOL_TABLE;
|
|
|
|
const
|
|
MaxLines = 1000;
|
|
|
|
procedure GenImport(kernel: TKernel;
|
|
L: TStrings;
|
|
StCard: Integer;
|
|
const ImportUnitName: String);
|
|
|
|
implementation
|
|
|
|
function CheckProc(const TypeName: String; Data: Pointer;
|
|
errKind: TExternRecKind): Boolean;
|
|
begin
|
|
result := false;
|
|
end;
|
|
|
|
procedure GenImport(kernel: TKernel;
|
|
L: TStrings;
|
|
StCard: Integer;
|
|
const ImportUnitName: String);
|
|
|
|
var
|
|
GTable: TBaseSymbolTable;
|
|
H_NS, H_SUB, H_TYPE: Integer;
|
|
|
|
function ProcessSub(Id: Integer): Integer; forward;
|
|
function ProcessProcType(Id: Integer): Integer; forward;
|
|
function ProcessClassType(Id: Integer): Integer; forward;
|
|
function ProcessClassRefType(Id: Integer): Integer; forward;
|
|
function ProcessInterfaceType(Id: Integer): Integer; forward;
|
|
function ProcessRecordType(Id: Integer): Integer; forward;
|
|
function ProcessArrayType(Id: Integer): Integer; forward;
|
|
function ProcessDynArrayType(Id: Integer): Integer; forward;
|
|
function ProcessSetType(Id: Integer): Integer; forward;
|
|
function ProcessPointerType(Id: Integer): Integer; forward;
|
|
function ProcessAliasType(Id: Integer): Integer; forward;
|
|
function ProcessSubrangeType(Id: Integer): Integer; forward;
|
|
function ProcessShortstringType(Id: Integer): Integer; forward;
|
|
function ProcessEnumType(Id: Integer): Integer; forward;
|
|
function ProcessConst(Id: Integer): Integer; forward;
|
|
|
|
function CallConvStr(R: TSymbolRec): String;
|
|
begin
|
|
case R.CallConv of
|
|
0: result := '_ccREGISTER';
|
|
ccSTDCALL: result := '_ccSTDCALL';
|
|
ccREGISTER: result := '_ccREGISTER';
|
|
ccCDECL: result := '_ccCDECL';
|
|
ccPASCAL: result := '_ccPASCAL';
|
|
ccSAFECALL: result := '_ccSAFECALL';
|
|
ccMSFASTCALL: result := '_ccMSFASTCALL';
|
|
else
|
|
raise Exception.Create(errInternalError);
|
|
end;
|
|
end;
|
|
|
|
function CallModeStr(R: TSymbolRec): String;
|
|
begin
|
|
case R.CallMode of
|
|
cmNONE: result := '_cmNONE';
|
|
cmVIRTUAL: result := '_cmVIRTUAL';
|
|
cmOVERRIDE: result := '_cmOVERRIDE';
|
|
else
|
|
raise Exception.Create(errInternalError);
|
|
end;
|
|
end;
|
|
|
|
function Tab(L: Integer): String;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
result := '';
|
|
for I:=1 to L do
|
|
result := result + ' ';
|
|
end;
|
|
|
|
var
|
|
LP, L1, L2, LU: TStringList;
|
|
Code: TCode;
|
|
SymbolTable: TSymbolTable;
|
|
Op: Integer;
|
|
|
|
procedure AddLine(const S: String);
|
|
begin
|
|
L.Add(S);
|
|
end;
|
|
|
|
procedure AddP(const S: String);
|
|
begin
|
|
LP.Add(S);
|
|
end;
|
|
|
|
procedure Add1(const S: String);
|
|
begin
|
|
if L1.IndexOf(S) = -1 then
|
|
L1.Add(S);
|
|
end;
|
|
|
|
procedure Add2(const S: String);
|
|
begin
|
|
L2.Add(S);
|
|
end;
|
|
|
|
procedure AddUnit(const S: String);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
for I:=0 to LU.Count - 1 do
|
|
if StrEql(LU[I], S) then
|
|
Exit;
|
|
LU.Add(S);
|
|
end;
|
|
|
|
procedure AddUnits;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
AddLine('uses');
|
|
for I:=0 to LU.Count - 1 do
|
|
if I < LU.Count - 1 then
|
|
AddLine(Tab(2) + LU[I] + ',')
|
|
else
|
|
AddLine(Tab(2) + LU[I] + ';');
|
|
end;
|
|
|
|
function StrLiteral(const S: String): String;
|
|
begin
|
|
result := '''' + S + '''';
|
|
end;
|
|
|
|
function UpdateTypeId(GTableRecNo: Integer; OldTypeId: Integer): Integer;
|
|
var
|
|
S: String;
|
|
begin
|
|
if OldTypeId < Types.Count then
|
|
begin
|
|
result := OldTypeId;
|
|
Exit;
|
|
end;
|
|
S := SymbolTable[OldTypeId].FullName;
|
|
result := GTable.LookupFullName(S, true);
|
|
if result > 0 then
|
|
Exit;
|
|
GTable.ExternList.Add(GTableRecNo,
|
|
S,
|
|
erTypeId);
|
|
end;
|
|
|
|
function ProcessOldType(OldTypeId: Integer): Integer;
|
|
var
|
|
S: String;
|
|
I: Integer;
|
|
R: TCodeRec;
|
|
begin
|
|
if OldTypeId < Types.Count then
|
|
begin
|
|
result := OldTypeId;
|
|
Exit;
|
|
end;
|
|
S := SymbolTable[OldTypeId].FullName;
|
|
result := GTable.LookupFullName(S, true);
|
|
if result > 0 then
|
|
Exit;
|
|
for I:=1 to Code.Card do
|
|
if Code[I].Arg1 = OldTypeId then
|
|
begin
|
|
R := Code[I];
|
|
Op := R.Op;
|
|
|
|
R.Op := OP_NOP;
|
|
if Op = OP_BEGIN_PROC_TYPE then
|
|
begin
|
|
result := ProcessProcType(R.Arg1);
|
|
break;
|
|
end
|
|
else if Op = OP_BEGIN_ALIAS_TYPE then
|
|
begin
|
|
result := ProcessAliasType(R.Arg1);
|
|
break;
|
|
end
|
|
else if Op = OP_BEGIN_CLASS_TYPE then
|
|
begin
|
|
result := ProcessClassType(R.Arg1);
|
|
break;
|
|
end
|
|
else if Op = OP_BEGIN_CLASSREF_TYPE then
|
|
begin
|
|
result := ProcessClassRefType(R.Arg1);
|
|
break;
|
|
end
|
|
else if Op = OP_BEGIN_INTERFACE_TYPE then
|
|
begin
|
|
result := ProcessInterfaceType(R.Arg1);
|
|
break;
|
|
end
|
|
else if Op = OP_BEGIN_RECORD_TYPE then
|
|
begin
|
|
result := ProcessRecordType(R.Arg1);
|
|
break;
|
|
end
|
|
else if Op = OP_BEGIN_ARRAY_TYPE then
|
|
begin
|
|
result := ProcessArrayType(R.Arg1);
|
|
break;
|
|
end
|
|
else if Op = OP_BEGIN_DYNARRAY_TYPE then
|
|
begin
|
|
result := ProcessDynArrayType(R.Arg1);
|
|
break;
|
|
end
|
|
else if Op = OP_BEGIN_SUBRANGE_TYPE then
|
|
begin
|
|
result := ProcessSubrangeType(R.Arg1);
|
|
break;
|
|
end
|
|
else if Op = OP_BEGIN_ENUM_TYPE then
|
|
begin
|
|
result := ProcessEnumType(R.Arg1);
|
|
break;
|
|
end
|
|
else if Op = OP_BEGIN_SET_TYPE then
|
|
begin
|
|
result := ProcessSetType(R.Arg1);
|
|
break;
|
|
end
|
|
else if Op = OP_BEGIN_POINTER_TYPE then
|
|
begin
|
|
result := ProcessPointerType(R.Arg1);
|
|
break;
|
|
end
|
|
else if Op = OP_BEGIN_SHORTSTRING_TYPE then
|
|
begin
|
|
result := ProcessShortstringType(R.Arg1);
|
|
break;
|
|
end
|
|
else if Op = OP_BEGIN_SUB then
|
|
begin
|
|
result := ProcessSub(R.Arg1);
|
|
break;
|
|
end
|
|
else if Op = OP_BEGIN_CONST then
|
|
begin
|
|
result := ProcessConst(R.Arg1);
|
|
break;
|
|
end
|
|
end;
|
|
end;
|
|
|
|
function UpdateLevelId(R: TSymbolRec): Integer;
|
|
var
|
|
S: String;
|
|
begin
|
|
result := R.Level;
|
|
if result > 0 then
|
|
begin
|
|
S := SymbolTable[result].FullName;
|
|
result := GTable.LookupFullName(S, true);
|
|
end;
|
|
end;
|
|
|
|
function ProcessNamespace(Id: Integer): Integer;
|
|
var
|
|
S: String;
|
|
begin
|
|
S := SymbolTable[Id].Name;
|
|
result := GTable.RegisterNamespace(0, S);
|
|
H_NS := result;
|
|
end;
|
|
|
|
function ProcessConst(Id: Integer): Integer;
|
|
var
|
|
ConstID, LevelId, ConstTypeId: Integer;
|
|
ConstName: String;
|
|
begin
|
|
ConstId := Id;
|
|
|
|
if SymbolTable[ConstId].OwnerId > 0 then
|
|
begin
|
|
result := 0;
|
|
Exit;
|
|
end;
|
|
|
|
LevelId := SymbolTable[ConstId].Level;
|
|
if LevelId = 0 then
|
|
LevelId := 0
|
|
else if SymbolTable[LevelId].Kind = kindNAMESPACE then
|
|
LevelId := H_NS
|
|
else
|
|
LevelId := UpdateLevelId(SymbolTable[ConstId]);
|
|
|
|
ConstName := SymbolTable[ConstId].Name;
|
|
ConstTypeId := ProcessOldType(SymbolTable[ConstId].TypeID);
|
|
|
|
result := GTable.RegisterConstant(LevelId, ConstName, ConstTypeId,
|
|
SymbolTable[ConstId].Value);
|
|
end;
|
|
|
|
function ProcessSub(Id: Integer): Integer;
|
|
var
|
|
I, SubID, LevelId, ResTypeId, CallConv, ParamId, ParamTypeId: Integer;
|
|
SubName: String;
|
|
SR: TSymbolRec;
|
|
IsMethod, InsideBody: Boolean;
|
|
CodeRec: TCodeRec;
|
|
begin
|
|
IsMethod := false;
|
|
|
|
InsideBody := false;
|
|
|
|
for I:=1 to Code.Card do
|
|
begin
|
|
CodeRec := Code[I];
|
|
if CodeRec.Op = OP_BEGIN_SUB then
|
|
begin
|
|
if CodeRec.Arg1 = Id then
|
|
begin
|
|
CodeRec.Op := OP_NOP;
|
|
InsideBody := true;
|
|
end;
|
|
end
|
|
else if CodeRec.Op = OP_END_SUB then
|
|
begin
|
|
if CodeRec.Arg1 = Id then
|
|
begin
|
|
CodeRec.Op := OP_NOP;
|
|
InsideBody := false;
|
|
end;
|
|
end
|
|
else if CodeRec.Op = OP_BEGIN_DYNARRAY_TYPE then
|
|
begin
|
|
if InsideBody then
|
|
begin
|
|
ProcessDynarrayType(CodeRec.Arg1);
|
|
CodeRec.Op := OP_NOP;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
SubId := Id;
|
|
|
|
for I:=0 to SymbolTable[SubId].Count - 1 do
|
|
begin
|
|
ParamId := SymbolTable.GetParamId(SubId, I);
|
|
SR := SymbolTable[ParamId];
|
|
if SR.TypeID = 0 then
|
|
begin
|
|
result := 0;
|
|
Exit;
|
|
end;
|
|
end;
|
|
|
|
LevelId := SymbolTable[SubId].Level;
|
|
if LevelId = 0 then
|
|
LevelId := 0
|
|
else if SymbolTable[LevelId].Kind = kindNAMESPACE then
|
|
LevelId := H_NS
|
|
else
|
|
begin
|
|
LevelId := H_TYPE;
|
|
IsMethod := true;
|
|
|
|
if SymbolTable[SubId].Vis <> cvPublic then
|
|
begin
|
|
result := 0;
|
|
Exit;
|
|
end;
|
|
end;
|
|
|
|
SubName := SymbolTable[SubId].Name;
|
|
CallConv := SymbolTable[SubId].CallConv;
|
|
|
|
if SubName <> '' then
|
|
if SubName[1] = '_' then
|
|
begin
|
|
result := 0;
|
|
Exit;
|
|
end;
|
|
|
|
ResTypeId := UpdateTypeId(GTable.Card + 1, SymbolTable[SubId].TypeID);
|
|
|
|
if IsMethod then
|
|
case SymbolTable[SubId].Kind of
|
|
kindCONSTRUCTOR: H_SUB := GTable.RegisterConstructor(LevelId, SubName, nil, ccREGISTER);
|
|
kindDESTRUCTOR: H_SUB := GTable.RegisterDestructor(LevelId, SubName, nil, ccREGISTER);
|
|
else
|
|
H_SUB := GTable.RegisterMethod(LevelId,
|
|
SubName,
|
|
ResTypeId,
|
|
CallConv,
|
|
nil,
|
|
SymbolTable[SubId].IsSharedMethod,
|
|
SymbolTable[SubId].CallMode,
|
|
SymbolTable[SubId].MethodIndex);
|
|
end
|
|
else
|
|
H_SUB := GTable.RegisterRoutine(LevelId, SubName, ResTypeId, CallConv, nil);
|
|
|
|
GTable[GTable.LastSubId].OverCount := SymbolTable[SubId].OverCount;
|
|
|
|
result := H_SUB;
|
|
|
|
for I:=0 to SymbolTable[SubId].Count - 1 do
|
|
begin
|
|
ParamId := SymbolTable.GetParamId(SubId, I);
|
|
SR := SymbolTable[ParamId];
|
|
|
|
ParamTypeId := UpdateTypeId(GTable.Card + 1, SR.TypeID);
|
|
|
|
GTable.RegisterParameter(H_SUB, ParamTypeId,
|
|
SR.Value, SR.ByRef, SR.Name);
|
|
if SR.IsConst then
|
|
GTable[GTable.Card].IsConst := true;
|
|
end;
|
|
end;
|
|
|
|
function ProcessProcType(Id: Integer): Integer;
|
|
var
|
|
LevelId, TypeId, DummySubId, FinTypeId: Integer;
|
|
TypeName: String;
|
|
begin
|
|
TypeId := Id;
|
|
|
|
LevelId := H_NS;
|
|
TypeName := SymbolTable[TypeId].Name;
|
|
DummySubId := SymbolTable[TypeId].PatternId;
|
|
|
|
if TypeName = '' then
|
|
begin
|
|
result := 0;
|
|
Exit;
|
|
end;
|
|
|
|
DummySubId := ProcessOldType(DummySubId);
|
|
|
|
FinTypeId := SymbolTable[TypeId].FinalTypeId;
|
|
|
|
case FinTypeId of
|
|
typePROC: result := GTable.RegisterProceduralType(LevelId,
|
|
TypeName,
|
|
DummySubId);
|
|
typeEVENT: result := GTable.RegisterEventType(LevelId,
|
|
TypeName,
|
|
DummySubId);
|
|
else
|
|
raise Exception.Create(errInternalError);
|
|
end;
|
|
end;
|
|
|
|
function ProcessSubrangeType(Id: Integer): Integer;
|
|
var
|
|
LevelId, TypeId, TypeBaseId: Integer;
|
|
TypeName: String;
|
|
B1, B2: Integer;
|
|
begin
|
|
TypeId := Id;
|
|
|
|
LevelId := H_NS;
|
|
TypeName := SymbolTable[TypeId].Name;
|
|
|
|
if TypeName = '' then
|
|
begin
|
|
result := 0;
|
|
Exit;
|
|
end;
|
|
|
|
TypeBaseId := ProcessOldType(SymbolTable[TypeId].TypeId);
|
|
B1 := SymbolTable.GetLowBoundRec(TypeId).Value;
|
|
B2 := SymbolTable.GetHighBoundRec(TypeId).Value;
|
|
|
|
result := GTable.RegisterSubrangeType(LevelId,
|
|
TypeName,
|
|
TypeBaseId,
|
|
B1, B2);
|
|
end;
|
|
|
|
function ProcessEnumType(Id: Integer): Integer;
|
|
var
|
|
I, LevelId, TypeId, TypeBaseId: Integer;
|
|
TypeName: String;
|
|
RI: TSymbolRec;
|
|
begin
|
|
TypeId := Id;
|
|
|
|
LevelId := H_NS;
|
|
TypeName := SymbolTable[TypeId].Name;
|
|
|
|
if TypeName = '' then
|
|
begin
|
|
result := 0;
|
|
Exit;
|
|
end;
|
|
|
|
TypeBaseId := SymbolTable[TypeId].PatternId;
|
|
|
|
TypeBaseId := ProcessOldType(TypeBaseId);
|
|
|
|
result := GTable.RegisterEnumType(LevelId,
|
|
TypeName,
|
|
TypeBaseId);
|
|
|
|
for I:=TypeId + 1 to SymbolTable.Card do
|
|
begin
|
|
RI := SymbolTable[I];
|
|
if RI.OwnerId = TypeId then
|
|
GTable.RegisterEnumValue(result,
|
|
RI.Name,
|
|
RI.Value);
|
|
end;
|
|
end;
|
|
|
|
function ProcessSetType(Id: Integer): Integer;
|
|
var
|
|
LevelId, TypeId, OriginTypeId: Integer;
|
|
TypeName: String;
|
|
begin
|
|
TypeId := Id;
|
|
|
|
LevelId := H_NS;
|
|
TypeName := SymbolTable[TypeId].Name;
|
|
|
|
if TypeName = '' then
|
|
begin
|
|
result := 0;
|
|
Exit;
|
|
end;
|
|
|
|
OriginTypeId := SymbolTable[TypeId].PatternId;
|
|
|
|
OriginTypeId := ProcessOldType(OriginTypeId);
|
|
|
|
result := GTable.RegisterSetType(LevelId,
|
|
TypeName,
|
|
OriginTypeId);
|
|
end;
|
|
|
|
function ProcessPointerType(Id: Integer): Integer;
|
|
var
|
|
LevelId, TypeId, OriginTypeId: Integer;
|
|
TypeName: String;
|
|
begin
|
|
TypeId := Id;
|
|
|
|
LevelId := H_NS;
|
|
TypeName := SymbolTable[TypeId].Name;
|
|
|
|
if TypeName = '' then
|
|
begin
|
|
result := 0;
|
|
Exit;
|
|
end;
|
|
|
|
OriginTypeId := SymbolTable[TypeId].PatternId;
|
|
|
|
OriginTypeId := ProcessOldType(OriginTypeId);
|
|
|
|
result := GTable.RegisterPointerType(LevelId,
|
|
TypeName,
|
|
OriginTypeId);
|
|
end;
|
|
|
|
function ProcessAliasType(Id: Integer): Integer;
|
|
var
|
|
LevelId, TypeId, OriginTypeId: Integer;
|
|
TypeName: String;
|
|
begin
|
|
TypeId := Id;
|
|
|
|
LevelId := H_NS;
|
|
TypeName := SymbolTable[TypeId].Name;
|
|
|
|
if TypeName = '' then
|
|
begin
|
|
result := 0;
|
|
Exit;
|
|
end;
|
|
|
|
OriginTypeId := SymbolTable[TypeId].PatternId;
|
|
OriginTypeId := ProcessOldType(OriginTypeId);
|
|
|
|
result := GTable.RegisterTypeAlias(LevelId,
|
|
TypeName,
|
|
OriginTypeId);
|
|
end;
|
|
|
|
function ProcessShortstringType(Id: Integer): Integer;
|
|
var
|
|
LevelId, TypeId, L: Integer;
|
|
TypeName: String;
|
|
begin
|
|
TypeId := Id;
|
|
|
|
LevelId := H_NS;
|
|
TypeName := SymbolTable[TypeId].Name;
|
|
L := SymbolTable[TypeId].Count;
|
|
|
|
if TypeName = '' then
|
|
begin
|
|
result := 0;
|
|
Exit;
|
|
end;
|
|
|
|
result := GTable.RegisterShortstringType(LevelId,
|
|
TypeName,
|
|
L);
|
|
end;
|
|
|
|
function ProcessClassType(Id: Integer): Integer;
|
|
var
|
|
I, J, K: Integer;
|
|
LevelId, TypeId, FieldTypeId, ReadId, WriteId, ParamTypeId, PropId,
|
|
_ReadId, _WriteId: Integer;
|
|
TypeName, SubName: String;
|
|
RI, RJ: TSymbolRec;
|
|
begin
|
|
TypeId := Id;
|
|
|
|
_ReadId := 0;
|
|
_WriteId := 0;
|
|
|
|
LevelId := H_NS;
|
|
TypeName := SymbolTable[TypeId].Name;
|
|
|
|
if TypeName = '' then
|
|
begin
|
|
result := 0;
|
|
Exit;
|
|
end;
|
|
|
|
H_TYPE := GTable.RegisterClassTypeForImporter(LevelId, TypeName);
|
|
result := H_TYPE;
|
|
|
|
for I:=TypeId + 1 to SymbolTable.Card do
|
|
begin
|
|
RI := SymbolTable[I];
|
|
|
|
if RI.Vis <> cvPublic then
|
|
continue;
|
|
|
|
if RI.Level = TypeId then
|
|
case RI.Kind of
|
|
kindTYPE_FIELD:
|
|
begin
|
|
FieldTypeId := UpdateTypeId(GTable.Card + 1, RI.TypeID);
|
|
GTable.RegisterTypeField(H_TYPE,
|
|
RI.Name,
|
|
FieldTypeID,
|
|
RI.Shift);
|
|
end;
|
|
kindPROP:
|
|
begin
|
|
FieldTypeId := UpdateTypeId(GTable.Card + 1, RI.TypeID);
|
|
if RI.ReadId > 0 then
|
|
begin
|
|
SubName := '@R_' + RI.FullName;
|
|
SubName := StringReplace(SubName, '.', '_', [rfReplaceAll, rfIgnoreCase]);
|
|
|
|
_ReadId := GTable.Card + 1;
|
|
|
|
ReadId := GTable.RegisterMethod(LevelId, SubName, FieldTypeId, ccSTDCALL, nil);
|
|
|
|
K := 0;
|
|
|
|
for J:=I + 1 to SymbolTable.Card do
|
|
begin
|
|
RJ := SymbolTable[J];
|
|
if RJ.Level = I then
|
|
if RJ.Kind = kindVAR then
|
|
if RJ.Name <> '' then
|
|
begin
|
|
Inc(K);
|
|
|
|
ParamTypeId := UpdateTypeId(GTable.Card + 1, RJ.TypeID);
|
|
|
|
GTable.RegisterParameter(ReadId, ParamTypeId,
|
|
RJ.Value, RJ.ByRef, RJ.Name);
|
|
if RJ.IsConst then
|
|
GTable[GTable.Card].IsConst := true;
|
|
|
|
if K = RI.Count then
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
end
|
|
else
|
|
ReadId := 0;
|
|
|
|
if RI.WriteId > 0 then
|
|
begin
|
|
SubName := '@W_' + RI.FullName;
|
|
SubName := StringReplace(SubName, '.', '_', [rfReplaceAll, rfIgnoreCase]);
|
|
|
|
_WriteId := GTable.Card + 1;
|
|
|
|
WriteId := GTable.RegisterMethod(LevelId, SubName, typeVOID, ccSTDCALL, nil);
|
|
|
|
K := 0;
|
|
|
|
for J:=I + 1 to SymbolTable.Card do
|
|
begin
|
|
RJ := SymbolTable[J];
|
|
if RJ.Level = I then
|
|
if RJ.Kind = kindVAR then
|
|
if RJ.Name <> '' then
|
|
begin
|
|
Inc(K);
|
|
|
|
ParamTypeId := UpdateTypeId(GTable.Card + 1, RJ.TypeID);
|
|
|
|
GTable.RegisterParameter(WriteId, ParamTypeId,
|
|
RJ.Value, RJ.ByRef, RJ.Name);
|
|
if RJ.IsConst then
|
|
GTable[GTable.Card].IsConst := true;
|
|
|
|
if K = RI.Count then
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
FieldTypeId := UpdateTypeId(GTable.Card + 1, RI.TypeID);
|
|
GTable.RegisterParameter(WriteId, FieldTypeId,
|
|
Unassigned, false, 'Value');
|
|
GTable[GTable.Card].IsConst := true;
|
|
end
|
|
else
|
|
WriteId := 0;
|
|
|
|
PropId := GTable.RegisterProperty(H_TYPE,
|
|
RI.Name,
|
|
FieldTypeId,
|
|
ReadId,
|
|
WriteId,
|
|
RI.IsDefault);
|
|
|
|
if RI.ReadId > 0 then
|
|
GTable[_ReadId].Position := PropId;
|
|
if RI.WriteId > 0 then
|
|
GTable[_WriteId].Position := PropId;
|
|
|
|
end;
|
|
kindSUB, kindCONSTRUCTOR, kindDESTRUCTOR:
|
|
begin
|
|
ProcessSub(I);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function ProcessClassRefType(Id: Integer): Integer;
|
|
var
|
|
LevelId, TypeId, OriginTypeId: Integer;
|
|
TypeName: String;
|
|
begin
|
|
TypeId := Id;
|
|
|
|
LevelId := H_NS;
|
|
TypeName := SymbolTable[TypeId].Name;
|
|
OriginTypeId := SymbolTable[TypeId].PatternId;
|
|
|
|
if TypeName = '' then
|
|
begin
|
|
result := 0;
|
|
Exit;
|
|
end;
|
|
|
|
OriginTypeId := ProcessOldType(OriginTypeId);
|
|
|
|
result := GTable.RegisterClassReferenceType(LevelId,
|
|
TypeName,
|
|
OriginTypeId);
|
|
end;
|
|
|
|
function ProcessInterfaceType(Id: Integer): Integer;
|
|
var
|
|
I: Integer;
|
|
LevelId, TypeId, FieldTypeId: Integer;
|
|
TypeName: String;
|
|
RI: TSymbolRec;
|
|
GUID: TGUID;
|
|
D: packed record D1, D2: Double end;
|
|
ReadIndex, WriteIndex: Integer;
|
|
begin
|
|
TypeId := Id;
|
|
|
|
LevelId := H_NS;
|
|
TypeName := SymbolTable[TypeId].Name;
|
|
D.D1 := SymbolTable[TypeId+1].Value;
|
|
D.D2 := SymbolTable[TypeId+2].Value;
|
|
GUID := TGUID(D);
|
|
|
|
if TypeName = '' then
|
|
begin
|
|
result := 0;
|
|
Exit;
|
|
end;
|
|
|
|
H_TYPE := GTable.RegisterInterfaceType(LevelId, TypeName, GUID);
|
|
result := H_TYPE;
|
|
|
|
for I:=TypeId + 1 to SymbolTable.Card do
|
|
begin
|
|
RI := SymbolTable[I];
|
|
|
|
if RI.Vis <> cvPublic then
|
|
continue;
|
|
|
|
if RI.Level = TypeId then
|
|
case RI.Kind of
|
|
kindPROP:
|
|
begin
|
|
FieldTypeId := UpdateTypeId(GTable.Card + 1, RI.TypeID);
|
|
if RI.ReadId > 0 then
|
|
ReadIndex := SymbolTable[RI.ReadId].MethodIndex
|
|
else
|
|
ReadIndex := 0;
|
|
if RI.WriteId > 0 then
|
|
WriteIndex := SymbolTable[RI.ReadId].MethodIndex
|
|
else
|
|
WriteIndex := 0;
|
|
GTable.RegisterInterfaceProperty(H_TYPE,
|
|
RI.Name,
|
|
FieldTypeId,
|
|
ReadIndex,
|
|
WriteIndex);
|
|
end;
|
|
kindSUB:
|
|
begin
|
|
ProcessSub(I);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function ProcessRecordType(Id: Integer): Integer;
|
|
var
|
|
I, K: Integer;
|
|
LevelId, TypeId, Align, FieldTypeId: Integer;
|
|
TypeName: String;
|
|
RI: TSymbolRec;
|
|
L: TIntegerList;
|
|
begin
|
|
TypeId := Id;
|
|
|
|
LevelId := H_NS;
|
|
TypeName := SymbolTable[TypeId].Name;
|
|
Align := SymbolTable[TypeId].DefaultAlignment;
|
|
|
|
if TypeName = '' then
|
|
begin
|
|
result := 0;
|
|
Exit;
|
|
end;
|
|
|
|
L := TIntegerList.Create;
|
|
for I:=TypeId + 1 to SymbolTable.Card do
|
|
begin
|
|
RI := SymbolTable[I];
|
|
if RI.Level = TypeId then
|
|
if RI.Kind = kindTYPE_FIELD then
|
|
begin
|
|
FieldTypeId := ProcessOldType(RI.TypeID);
|
|
L.Add(FieldTypeId);
|
|
end;
|
|
end;
|
|
|
|
try
|
|
|
|
H_TYPE := GTable.RegisterRecordType(LevelId, TypeName, Align);
|
|
result := H_TYPE;
|
|
|
|
K := -1;
|
|
|
|
for I:=TypeId + 1 to SymbolTable.Card do
|
|
begin
|
|
RI := SymbolTable[I];
|
|
if RI.Level = TypeId then
|
|
if RI.Kind = kindTYPE_FIELD then
|
|
begin
|
|
Inc(K);
|
|
FieldTypeId := L[K];
|
|
GTable.RegisterTypeField(H_TYPE,
|
|
RI.Name,
|
|
FieldTypeID,
|
|
RI.Shift);
|
|
end;
|
|
end;
|
|
|
|
finally
|
|
L.Free;
|
|
end;
|
|
end;
|
|
|
|
function ProcessArrayType(Id: Integer): Integer;
|
|
var
|
|
LevelId, TypeId, Align, RangeTypeId, ElemTypeId: Integer;
|
|
TypeName: String;
|
|
begin
|
|
TypeId := Id;
|
|
|
|
SymbolTable.GetArrayTypeInfo(TypeId, RangeTypeId, ElemTypeId);
|
|
|
|
LevelId := H_NS;
|
|
TypeName := SymbolTable[TypeId].Name;
|
|
Align := SymbolTable[TypeId].DefaultAlignment;
|
|
|
|
if TypeName = '' then
|
|
begin
|
|
result := 0;
|
|
Exit;
|
|
end;
|
|
|
|
RangeTypeId := ProcessOldType(RangeTypeId);
|
|
ElemTypeId := ProcessOldType(ElemTypeId);
|
|
|
|
result := GTable.RegisterArrayType(LevelId, TypeName,
|
|
RangeTypeId, ElemTypeId, Align);
|
|
end;
|
|
|
|
function ProcessDynArrayType(Id: Integer): Integer;
|
|
var
|
|
LevelId, TypeId, ElemTypeId: Integer;
|
|
TypeName: String;
|
|
begin
|
|
TypeId := Id;
|
|
|
|
LevelId := H_NS;
|
|
TypeName := SymbolTable[TypeId].Name;
|
|
ElemTypeId := SymbolTable[TypeId].PatternId;
|
|
|
|
if TypeName = '' then
|
|
begin
|
|
result := 0;
|
|
Exit;
|
|
end;
|
|
|
|
ElemTypeId := ProcessOldType(ElemTypeId);
|
|
|
|
result := GTable.RegisterDynamicArrayType(LevelId, TypeName,
|
|
ElemTypeId);
|
|
end;
|
|
|
|
function GetStrTypeConst(TypeId: Integer): String;
|
|
var
|
|
T: Integer;
|
|
S: String;
|
|
begin
|
|
if TypeId in [0, typeVOID] then
|
|
result := '_typeVOID'
|
|
else
|
|
begin
|
|
if TypeId >= FirstLocalId then
|
|
T := TypeId - FirstLocalId + StCard
|
|
else
|
|
T := TypeId;
|
|
|
|
S := GTable[TypeId].Name;
|
|
if PosCh('#', S) > 0 then
|
|
S := RemoveCh('#', S);
|
|
|
|
if PosCh('$', S) > 0 then
|
|
S := 'AType';
|
|
|
|
result := S + '_' + IntToStr(T);
|
|
|
|
Add1('const ' + result + ' = ' + IntToStr(T) + '; // ' + IntToStr(TypeId));
|
|
end;
|
|
end;
|
|
|
|
function GetTypeName(R: TSymbolRec): String;
|
|
var
|
|
T: Integer;
|
|
begin
|
|
result := GTable[R.TypeId].Name;
|
|
if R.FinalTypeId = typeDYNARRAY then
|
|
begin
|
|
if Pos('DynarrayType_', result) = 1 then
|
|
begin
|
|
T := GTable[R.TypeID].PatternId;
|
|
if T = H_TVarRec then
|
|
result := 'array of const'
|
|
else
|
|
result := 'array of ' + GTable[T].Name;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function CheckSub(SubId: Integer): Boolean;
|
|
var
|
|
I, ParamId: Integer;
|
|
begin
|
|
result := true;
|
|
if GTable[SubId].TypeID = 0 then
|
|
begin
|
|
result := false;
|
|
Exit;
|
|
end;
|
|
for I:=0 to GTable[SubId].Count - 1 do
|
|
begin
|
|
ParamId := GTable.GetParamId(SubId, I);
|
|
if GTable[ParamId].TypeID = 0 then
|
|
begin
|
|
result := false;
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function SubSize(SubId: Integer): Integer;
|
|
var
|
|
K: Integer;
|
|
begin
|
|
K := GTable[SubId].Count;
|
|
if K = 0 then
|
|
result := 3
|
|
else
|
|
result := GTable.GetParamId(SubId, K - 1) - SubId + 1;
|
|
end;
|
|
|
|
function CheckProp(PropId: Integer): Boolean;
|
|
begin
|
|
result := GTable[PropId].TypeID <> 0;
|
|
end;
|
|
|
|
function PropSize(PropId: Integer): Integer;
|
|
begin
|
|
result := 2;
|
|
end;
|
|
|
|
var
|
|
RegProcName: String;
|
|
T, KK, I, J, K, RangeTypeId, ElemTypeId, TotalOverCount: Integer;
|
|
RI, RJ: TSymbolRec;
|
|
R: TCodeRec;
|
|
|
|
S, StrLevelConst, StrTypeConst, StrCallConv, StrCallMode, StrAddress, StrValue,
|
|
SubName, TypeName, StrRead, StrWrite: String;
|
|
NewKernel: TKernel;
|
|
RegisteredClasses: TStringList;
|
|
begin
|
|
RegProcName := 'Register_' + ImportUnitName;
|
|
Code := TKernel(kernel).Code;
|
|
SymbolTable := TKernel(kernel).SymbolTable;
|
|
|
|
LP := TStringList.Create;
|
|
L1 := TStringList.Create;
|
|
L2 := TStringList.Create;
|
|
LU := TStringList.Create;
|
|
RegisteredClasses := TStringList.Create;
|
|
|
|
NewKernel := TKernel.Create(nil);
|
|
GTable := NewKernel.SymbolTable;
|
|
|
|
try
|
|
AddUnit('Types');
|
|
AddUnit('Classes');
|
|
AddUnit('PaxCompiler');
|
|
AddUnit('PaxRegister');
|
|
|
|
for I:=1 to Code.Card do
|
|
begin
|
|
R := Code[I];
|
|
Op := R.Op;
|
|
if Op = OP_BEGIN_NAMESPACE then
|
|
ProcessNamespace(R.Arg1)
|
|
else if Op = OP_BEGIN_PROC_TYPE then
|
|
ProcessProcType(R.Arg1)
|
|
else if Op = OP_BEGIN_ALIAS_TYPE then
|
|
ProcessAliasType(R.Arg1)
|
|
else if Op = OP_BEGIN_INTERFACE_TYPE then
|
|
ProcessInterfaceType(R.Arg1)
|
|
else if Op = OP_BEGIN_CLASS_TYPE then
|
|
ProcessClassType(R.Arg1)
|
|
else if Op = OP_BEGIN_CLASSREF_TYPE then
|
|
ProcessClassRefType(R.Arg1)
|
|
else if Op = OP_BEGIN_RECORD_TYPE then
|
|
ProcessRecordType(R.Arg1)
|
|
else if Op = OP_BEGIN_ARRAY_TYPE then
|
|
ProcessArrayType(R.Arg1)
|
|
else if Op = OP_BEGIN_DYNARRAY_TYPE then
|
|
ProcessDynArrayType(R.Arg1)
|
|
else if Op = OP_BEGIN_SUBRANGE_TYPE then
|
|
ProcessSubrangeType(R.Arg1)
|
|
else if Op = OP_BEGIN_ENUM_TYPE then
|
|
ProcessEnumType(R.Arg1)
|
|
else if Op = OP_BEGIN_SET_TYPE then
|
|
ProcessSetType(R.Arg1)
|
|
else if Op = OP_BEGIN_POINTER_TYPE then
|
|
ProcessPointerType(R.Arg1)
|
|
else if Op = OP_BEGIN_SHORTSTRING_TYPE then
|
|
ProcessShortstringType(R.Arg1)
|
|
else if Op = OP_BEGIN_SUB then
|
|
ProcessSub(R.Arg1)
|
|
else if Op = OP_BEGIN_CONST then
|
|
ProcessConst(R.Arg1);
|
|
R.Op := OP_NOP;
|
|
end;
|
|
|
|
GTable.ResolveExternList(CheckProc, nil);
|
|
|
|
TotalOverCount := 0;
|
|
|
|
for I:=FirstLocalId + 1 to GTable.Card do
|
|
begin
|
|
RI := GTable[I];
|
|
|
|
KK := I - FirstLocalId + StCard;
|
|
|
|
if Length(RI.Name) = 0 then
|
|
continue;
|
|
|
|
case RI.Kind of
|
|
KindNAMESPACE:
|
|
begin
|
|
AddUnit(RI.Name);
|
|
|
|
Add2(Tab(2) + 'H_NS := ' + 'RegisterNamespace(0, ' +
|
|
StrLiteral(RI.Name) +
|
|
');' + '//' + IntToStr(KK));
|
|
end;
|
|
KindCONST:
|
|
begin
|
|
If RI.OwnerId > 0 then
|
|
continue;
|
|
|
|
If RI.Level = 0 then
|
|
StrLevelConst := '0'
|
|
else if GTable[RI.Level].Kind = kindNAMESPACE then
|
|
StrLevelConst := 'H_NS';
|
|
StrTypeConst := GetStrTypeConst(RI.TypeId);
|
|
StrValue := GTable.ValueStr(I);
|
|
if PosCh('[', StrValue) > 0 then
|
|
StrValue := '0';
|
|
if RI.FinalTypeId in StringTypes then
|
|
StrValue := '''' + StrValue + '''';
|
|
if RI.HasPAnsiCharType then
|
|
StrValue := '''' + StrValue + '''';
|
|
Add2(Tab(2) + 'RegisterConstant(' +
|
|
StrLevelConst + ',' +
|
|
StrLiteral(RI.Name) + ',' +
|
|
StrTypeConst + ',' +
|
|
StrValue +
|
|
');' + '//' + IntToStr(KK));
|
|
end;
|
|
KindSUB, kindCONSTRUCTOR, kindDESTRUCTOR:
|
|
begin
|
|
if not CheckSub(I) then
|
|
begin
|
|
Add2(Tab(2) + '// Cannot import "' + RI.FullName + '"');
|
|
Add2(Tab(2) + 'RegisterSpace(' + IntToStr(SubSize(I)) + ');');
|
|
continue;
|
|
end;
|
|
|
|
If RI.Level = 0 then
|
|
StrLevelConst := '0'
|
|
else if GTable[RI.Level].Kind = kindNAMESPACE then
|
|
StrLevelConst := 'H_NS'
|
|
else
|
|
StrLevelConst := 'H_TYPE';
|
|
|
|
StrTypeConst := GetStrTypeConst(RI.TypeId);
|
|
|
|
StrCallConv := CallConvStr(RI);
|
|
StrCallMode := CallModeStr(RI);
|
|
|
|
if PosCh('#', RI.Name) = 1 then
|
|
StrAddress := 'nil'
|
|
else
|
|
StrAddress := '@' + RI.FullName;
|
|
|
|
case RI.Kind of
|
|
kindCONSTRUCTOR:
|
|
begin
|
|
if RI.OverCount > 0 then
|
|
begin
|
|
Inc(TotalOverCount);
|
|
SubName := RI.FullName + '__' + IntToStr(TotalOverCount);
|
|
SubName := StringReplace(SubName, '.', '_', [rfReplaceAll, rfIgnoreCase]);
|
|
|
|
StrAddress := '@' + SubName;
|
|
|
|
S := 'function ' + SubName + '(';
|
|
|
|
for J:=0 to RI.Count - 1 do
|
|
begin
|
|
RJ := GTable[GTable.GetParamId(I, J)];
|
|
if RJ.IsConst then
|
|
S := S + 'const '
|
|
else if RJ.ByRef then
|
|
S := S + 'var ';
|
|
S := S + RJ.Name;
|
|
if not StrEql(GetTypeName(RJ), 'PVOID') then
|
|
S := S + ':' + GetTypeName(RJ);
|
|
if J <> RI.Count - 1 then
|
|
S := S + ';'
|
|
end;
|
|
|
|
S := S + '):' + GTable[RI.TypeId].Name + ';';
|
|
|
|
AddP(S);
|
|
AddP('begin');
|
|
|
|
S := 'result := ' + GTable[RI.TypeId].Name + '.' + RI.Name + '(';
|
|
for J:=0 to RI.Count - 1 do
|
|
begin
|
|
RJ := GTable[GTable.GetParamId(I, J)];
|
|
S := S + RJ.Name;
|
|
if J <> RI.Count - 1 then
|
|
S := S + ','
|
|
end;
|
|
S := S + ');';
|
|
|
|
AddP(Tab(2) + S);
|
|
AddP('end;');
|
|
|
|
Add2(Tab(2) + 'H_SUB := ' + 'RegisterMethod(' +
|
|
StrLevelConst + ',' +
|
|
StrLiteral(RI.Name) + ',' +
|
|
StrTypeConst + ',' +
|
|
StrAddress + ',' +
|
|
StrCallConv + ',' +
|
|
'true' +
|
|
');' + '//' + IntToStr(KK));
|
|
end
|
|
else
|
|
Add2(Tab(2) + 'H_SUB := ' + 'RegisterConstructor(' +
|
|
StrLevelConst + ',' +
|
|
StrLiteral(RI.Name) + ',' +
|
|
StrAddress +
|
|
');' + '//' + IntToStr(KK));
|
|
end;
|
|
kindDESTRUCTOR:
|
|
Add2(Tab(2) + 'RegisterDestructor(' +
|
|
StrLevelConst + ',' +
|
|
StrLiteral(RI.Name) + ',' +
|
|
StrAddress +
|
|
');' + '//' + IntToStr(KK));
|
|
else
|
|
if StrLevelConst = 'H_TYPE' then
|
|
begin
|
|
if RI.OverCount > 0 then
|
|
begin
|
|
Inc(TotalOverCount);
|
|
SubName := RI.FullName + '__' + IntToStr(TotalOverCount);
|
|
SubName := StringReplace(SubName, '.', '_', [rfReplaceAll, rfIgnoreCase]);
|
|
|
|
StrAddress := '@' + SubName;
|
|
|
|
if RI.TypeID in [0, typeVOID] then
|
|
S := 'procedure '
|
|
else
|
|
S := 'function ';
|
|
S := S + SubName + '(Self:' + GTable[RI.Level].Name;
|
|
|
|
if RI.Count <> 0 then
|
|
S := S + ';';
|
|
|
|
for J:=0 to RI.Count - 1 do
|
|
begin
|
|
RJ := GTable[GTable.GetParamId(I, J)];
|
|
if RJ.IsConst then
|
|
S := S + 'const '
|
|
else if RJ.ByRef then
|
|
S := S + 'var ';
|
|
S := S + RJ.Name;
|
|
if not StrEql(GetTypeName(RJ), 'PVOID') then
|
|
S := S + ':' + GetTypeName(RJ);
|
|
if J <> RI.Count - 1 then
|
|
S := S + ';'
|
|
end;
|
|
|
|
S := S + ')';
|
|
|
|
if not (RI.TypeID in [0, typeVOID]) then
|
|
S := S + ':' + GTable[RI.TypeId].Name;
|
|
|
|
S := S + ';' + Copy(StrCallConv, 4, Length(StrCallConv) - 3) + ';';
|
|
|
|
AddP(S);
|
|
AddP('begin');
|
|
|
|
if not (RI.TypeID in [0, typeVOID]) then // procedure
|
|
S := 'result := Self.'
|
|
else
|
|
S := 'Self.';
|
|
|
|
S := S + RI.Name + '(';
|
|
for J:=0 to RI.Count - 1 do
|
|
begin
|
|
RJ := GTable[GTable.GetParamId(I, J)];
|
|
S := S + RJ.Name;
|
|
if J <> RI.Count - 1 then
|
|
S := S + ','
|
|
end;
|
|
S := S + ');';
|
|
|
|
AddP(Tab(2) + S);
|
|
AddP('end;');
|
|
|
|
end;
|
|
|
|
if RI.Level > 0 then
|
|
if GTable[RI.Level].FinalTypeId = typeINTERFACE then
|
|
StrAddress := 'nil';
|
|
|
|
Add2(Tab(2) + 'H_SUB := ' + 'RegisterMethod(' +
|
|
StrLevelConst + ',' +
|
|
StrLiteral(RI.Name) + ',' +
|
|
StrTypeConst + ',' +
|
|
StrAddress + ',' +
|
|
StrCallConv + ',' +
|
|
BoolToStr(RI.IsSharedMethod, true) + ',' +
|
|
StrCallMode + ',' +
|
|
IntToStr(RI.MethodIndex) +
|
|
');' + '//' + IntToStr(KK));
|
|
end
|
|
else
|
|
begin
|
|
if PosCh('@', RI.Name) = 1 then
|
|
begin
|
|
SubName := RI.Name;
|
|
TypeName := GTable[Gtable[RI.Position].Level].Name;
|
|
|
|
if RI.Name[2] = 'R' then
|
|
begin
|
|
SubName := StringReplace(SubName, '@', '', [rfReplaceAll, rfIgnoreCase]);
|
|
|
|
S := 'function ' + SubName + '(Self:' + TypeName;
|
|
if RI.Count <> 0 then
|
|
S := S + ';';
|
|
|
|
for J:=0 to RI.Count - 1 do
|
|
begin
|
|
RJ := GTable[GTable.GetParamId(I, J)];
|
|
if RJ.IsConst then
|
|
S := S + 'const '
|
|
else if RJ.ByRef then
|
|
S := S + 'var ';
|
|
S := S + RJ.Name;
|
|
if not StrEql(GetTypeName(RJ), 'PVOID') then
|
|
S := S + ':' + GetTypeName(RJ);
|
|
if J <> RI.Count - 1 then
|
|
S := S + ';'
|
|
end;
|
|
S := S + '):' + GTable[RI.TypeId].Name + '; stdcall;';
|
|
AddP(S);
|
|
AddP('begin');
|
|
S := 'result := Self.' + Gtable[RI.Position].Name;
|
|
if RI.Count > 0 then
|
|
begin
|
|
S := S + '[';
|
|
for J:=0 to RI.Count - 1 do
|
|
begin
|
|
RJ := GTable[GTable.GetParamId(I, J)];
|
|
S := S + RJ.Name;
|
|
if J <> RI.Count - 1 then
|
|
S := S + ','
|
|
end;
|
|
S := S + ']';
|
|
end;
|
|
AddP(Tab(2) + S + ';');
|
|
AddP('end;');
|
|
|
|
Add2(Tab(2) + 'H_SUB := ' + 'RegisterRoutine(' +
|
|
StrLevelConst + ',' +
|
|
StrLiteral(SubName) + ',' +
|
|
StrTypeConst + ',' +
|
|
'@' + SubName + ',' +
|
|
StrCallConv +
|
|
');'+ '//' + IntToStr(KK));
|
|
Add2(Tab(2) + 'H_READ := H_SUB;');
|
|
end
|
|
else
|
|
begin
|
|
SubName := StringReplace(SubName, '@', '', [rfReplaceAll, rfIgnoreCase]);
|
|
|
|
S := 'procedure ' + SubName + '(Self:' + TypeName;
|
|
if RI.Count <> 0 then
|
|
S := S + ';';
|
|
|
|
for J:=0 to RI.Count - 1 do
|
|
begin
|
|
RJ := GTable[GTable.GetParamId(I, J)];
|
|
if RJ.IsConst then
|
|
S := S + 'const '
|
|
else if RJ.ByRef then
|
|
S := S + 'var ';
|
|
S := S + RJ.Name;
|
|
if not StrEql(GetTypeName(RJ), 'PVOID') then
|
|
S := S + ':' + GetTypeName(RJ);
|
|
if J <> RI.Count - 1 then
|
|
S := S + ';'
|
|
end;
|
|
S := S + '); stdcall;';
|
|
AddP(S);
|
|
AddP('begin');
|
|
S := 'Self.' + Gtable[RI.Position].Name;
|
|
if RI.Count > 1 then
|
|
begin
|
|
S := S + '[';
|
|
for J:=0 to RI.Count - 2 do
|
|
begin
|
|
RJ := GTable[GTable.GetParamId(I, J)];
|
|
S := S + RJ.Name;
|
|
if J <> RI.Count - 2 then
|
|
S := S + ','
|
|
end;
|
|
S := S + ']';
|
|
end;
|
|
AddP(Tab(2) + S + ' := value;');
|
|
AddP('end;');
|
|
|
|
Add2(Tab(2) + 'H_SUB := ' + 'RegisterRoutine(' +
|
|
StrLevelConst + ',' +
|
|
StrLiteral(SubName) + ',' +
|
|
StrTypeConst + ',' +
|
|
'@' + SubName + ',' +
|
|
StrCallConv +
|
|
');'+ '//' + IntToStr(KK));
|
|
Add2(Tab(2) + 'H_WRITE := H_SUB;');
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
if RI.OverCount > 0 then
|
|
begin
|
|
Inc(TotalOverCount);
|
|
SubName := RI.Name + '__' + IntToStr(TotalOverCount);
|
|
|
|
StrAddress := '@' + SubName;
|
|
|
|
if RI.TypeID in [0, typeVOID] then
|
|
S := 'procedure '
|
|
else
|
|
S := 'function ';
|
|
S := S + SubName + '(';
|
|
|
|
for J:=0 to RI.Count - 1 do
|
|
begin
|
|
RJ := GTable[GTable.GetParamId(I, J)];
|
|
if RJ.IsConst then
|
|
S := S + 'const '
|
|
else if RJ.ByRef then
|
|
S := S + 'var ';
|
|
S := S + RJ.Name;
|
|
if not StrEql(GetTypeName(RJ), 'PVOID') then
|
|
S := S + ':' + GetTypeName(RJ);
|
|
if J <> RI.Count - 1 then
|
|
S := S + ';'
|
|
end;
|
|
|
|
S := S + ')';
|
|
|
|
if not (RI.TypeID in [0, typeVOID]) then
|
|
S := S + ':' + GTable[RI.TypeId].Name;
|
|
|
|
S := S + ';' + Copy(StrCallConv, 4, Length(StrCallConv) - 3) + ';';
|
|
|
|
AddP(S);
|
|
AddP('begin');
|
|
|
|
S := '';
|
|
|
|
if not (RI.TypeID in [0, typeVOID]) then // procedure
|
|
S := 'result := ';
|
|
|
|
S := S + RI.Name + '(';
|
|
for J:=0 to RI.Count - 1 do
|
|
begin
|
|
RJ := GTable[GTable.GetParamId(I, J)];
|
|
S := S + RJ.Name;
|
|
if J <> RI.Count - 1 then
|
|
S := S + ','
|
|
end;
|
|
S := S + ');';
|
|
|
|
AddP(Tab(2) + S);
|
|
AddP('end;');
|
|
|
|
end;
|
|
|
|
Add2(Tab(2) + 'H_SUB := ' + 'RegisterRoutine(' +
|
|
StrLevelConst + ',' +
|
|
StrLiteral(RI.Name) + ',' +
|
|
StrTypeConst + ',' +
|
|
StrAddress + ',' +
|
|
StrCallConv +
|
|
');'+ '//' + IntToStr(KK));
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
Inc(KK, 2);
|
|
|
|
for J:=0 to GTable[I].Count - 1 do
|
|
begin
|
|
RJ := GTable[GTable.GetParamId(I, J)];
|
|
|
|
if RJ.Optional then
|
|
StrValue := VarToStr(RJ.Value)
|
|
else
|
|
StrValue := 'Undefined';
|
|
|
|
Inc(KK);
|
|
|
|
Add2(Tab(4) + 'RegisterParameterEx(H_SUB, ' +
|
|
StrLiteral(RJ.Name) + ',' +
|
|
GetStrTypeConst(RJ.TypeId) + ',' +
|
|
StrValue + ',' +
|
|
BoolToStr(RJ.ByRef, true) + ',' +
|
|
BoolToStr(RJ.IsConst, true) +
|
|
');'+ '//' + IntToStr(KK));
|
|
end;
|
|
|
|
end;
|
|
kindPROP:
|
|
begin
|
|
if not CheckProp(I) then
|
|
begin
|
|
Add2(Tab(2) + '// Cannot import "' + RI.FullName + '"');
|
|
Add2(Tab(2) + 'RegisterSpace(' + IntToStr(PropSize(I)) + ');');
|
|
continue;
|
|
end;
|
|
|
|
StrTypeConst := GetStrTypeConst(RI.TypeId);
|
|
|
|
if (RI.Level > 0) and (GTable[RI.Level].FinalTypeId = typeINTERFACE) then
|
|
begin
|
|
if RI.ReadId > 0 then
|
|
StrRead := IntToStr(GTable[RI.ReadId].MethodIndex)
|
|
else
|
|
StrRead := '0';
|
|
|
|
if RI.WriteId > 0 then
|
|
StrWrite := IntToStr(GTable[RI.WriteId].MethodIndex)
|
|
else
|
|
StrWrite := '0';
|
|
|
|
Add2(Tab(2) + 'RegisterInterfaceProperty(H_TYPE,' +
|
|
StrLiteral(RI.Name) + ',' +
|
|
StrTypeConst + ',' +
|
|
StrRead + ',' +
|
|
StrWrite +
|
|
');' + '//' + IntToStr(KK));
|
|
end
|
|
else
|
|
begin
|
|
if RI.ReadId > 0 then
|
|
StrRead := 'H_READ'
|
|
else
|
|
StrRead := '0';
|
|
if RI.WriteId > 0 then
|
|
StrWrite := 'H_WRITE'
|
|
else
|
|
StrWrite := '0';
|
|
Add2(Tab(2) + 'RegisterProperty(H_TYPE,' +
|
|
StrLiteral(RI.Name) + ',' +
|
|
StrTypeConst + ',' +
|
|
StrRead + ',' +
|
|
StrWrite + ',' +
|
|
BoolToStr(RI.IsDefault, true) +
|
|
');' + '//' + IntToStr(KK));
|
|
end;
|
|
end;
|
|
kindTYPE:
|
|
begin
|
|
StrLevelConst := 'H_NS';
|
|
|
|
T := RI.TypeId;
|
|
if T = typeALIAS then
|
|
begin
|
|
// alias
|
|
end
|
|
else
|
|
T := RI.FinalTypeId;
|
|
|
|
case T of
|
|
typeRECORD:
|
|
begin
|
|
Add2(Tab(2) + 'RegisterAlignment(' + IntToStr(RI.DefaultAlignment) + ');');
|
|
|
|
Add2(Tab(2) + 'H_TYPE := ' + 'RegisterRecordType(' +
|
|
StrLevelConst + ',' +
|
|
StrLiteral(RI.Name) +
|
|
');' + '//' + IntToStr(KK));
|
|
|
|
for J:=I + 1 to GTable.Card do
|
|
begin
|
|
RJ := GTable[J];
|
|
if RJ.Level = I then
|
|
if RJ.Kind = kindTYPE_FIELD then
|
|
begin
|
|
StrTypeConst := GetStrTypeConst(RJ.TypeId);
|
|
|
|
Inc(KK);
|
|
|
|
Add2(Tab(4) + 'RegisterRecordTypeField(H_TYPE, ' +
|
|
StrLiteral(RJ.Name) + ',' +
|
|
StrTypeConst + ',' +
|
|
IntToStr(RJ.Shift) +
|
|
');' + '//' + IntToStr(KK));
|
|
end;
|
|
end;
|
|
end;
|
|
typeCLASS:
|
|
begin
|
|
Add2(Tab(2) + 'H_TYPE := ' + 'RegisterClassTypeForImporter(' +
|
|
StrLevelConst + ',' +
|
|
RI.Name +
|
|
');' + '//' + IntToStr(KK));
|
|
|
|
RegisteredClasses.AddObject(RI.Name, TObject(KK));
|
|
|
|
Inc(KK, 3);
|
|
|
|
for J:=I + 1 to GTable.Card do
|
|
begin
|
|
RJ := GTable[J];
|
|
if RJ.Level = I then
|
|
case RJ.Kind of
|
|
kindTYPE_FIELD:
|
|
begin
|
|
Inc(KK);
|
|
|
|
StrTypeConst := GetStrTypeConst(RJ.TypeId);
|
|
Add2(Tab(4) + 'RegisterClassTypeField(H_TYPE, ' +
|
|
StrLiteral(RJ.Name) + ',' +
|
|
StrTypeConst + ',' +
|
|
'Integer(@' + GTable[RJ.Level].Name + '(nil).' + RJ.Name + ')' +
|
|
');' + '//' + IntToStr(KK));
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
typeCLASSREF:
|
|
begin
|
|
Add2(Tab(2) + 'RegisterClassReferenceType(' +
|
|
StrLevelConst + ',' +
|
|
StrLiteral(RI.Name) + ',' +
|
|
GetStrTypeConst(RI.PatternId) +
|
|
');' + '//' + IntToStr(KK));
|
|
end;
|
|
typeINTERFACE:
|
|
begin
|
|
Add2(Tab(2) + 'H_TYPE := ' + 'RegisterInterfaceType(' +
|
|
StrLevelConst + ',' +
|
|
StrLiteral(RI.Name) + ',' +
|
|
RI.Name +
|
|
');' + '//' + IntToStr(KK));
|
|
end;
|
|
typeARRAY:
|
|
begin
|
|
Add2(Tab(2) + 'RegisterAlignment(' + IntToStr(1) + ');');
|
|
|
|
GTable.GetArrayTypeInfo(I, RangeTypeId, ElemTypeId);
|
|
Add2(Tab(2) + 'RegisterArrayType(' +
|
|
StrLevelConst + ',' +
|
|
StrLiteral(RI.Name) + ',' +
|
|
GetStrTypeConst(RangeTypeId) + ',' +
|
|
GetStrTypeConst(ElemTypeId) +
|
|
');' + '//' + IntToStr(KK));
|
|
end;
|
|
typeDYNARRAY:
|
|
begin
|
|
Add2(Tab(2) + 'RegisterAlignment(' + IntToStr(1) + ');');
|
|
|
|
ElemTypeId := RI.PatternId;
|
|
|
|
Add2(Tab(2) + 'RegisterDynamicArrayType(' +
|
|
StrLevelConst + ',' +
|
|
StrLiteral(RI.Name) + ',' +
|
|
GetStrTypeConst(ElemTypeId) +
|
|
');' + '//' + IntToStr(KK));
|
|
end;
|
|
typeENUM:
|
|
begin
|
|
if (GTable[I+1].Kind = kindCONST) and
|
|
(GTable[I+1].TypeId = typeENUM) then
|
|
begin
|
|
Add2(Tab(2) + 'RegisterSubrangeType(' +
|
|
StrLevelConst + ',' +
|
|
StrLiteral(RI.Name) + ',' +
|
|
GetStrTypeConst(RI.TypeId) + ',' +
|
|
IntToStr(GTable.GetLowBoundRec(I).Value) + ',' +
|
|
IntToStr(GTable.GetHighBoundRec(I).Value) +
|
|
');' + '//' + IntToStr(KK));
|
|
continue;
|
|
end;
|
|
|
|
Add2(Tab(2) + 'H_TYPE := ' + 'RegisterEnumType(' +
|
|
StrLevelConst + ',' +
|
|
StrLiteral(RI.Name) +
|
|
');' + '//' + IntToStr(KK));
|
|
for J:=I + 1 to GTable.Card do
|
|
begin
|
|
RJ := GTable[J];
|
|
if RJ.OwnerId = I then
|
|
begin
|
|
Inc(KK);
|
|
|
|
Add2(Tab(4) + 'RegisterEnumValue(H_TYPE, ' +
|
|
StrLiteral(RJ.Name) + ',' +
|
|
IntToStr(RJ.Value) +
|
|
');' + '//' + IntToStr(KK));
|
|
end;
|
|
end;
|
|
end;
|
|
typeSET:
|
|
begin
|
|
Add2(Tab(2) + 'RegisterSetType(' +
|
|
StrLevelConst + ',' +
|
|
StrLiteral(RI.Name) + ',' +
|
|
GetStrTypeConst(RI.PatternId) +
|
|
');' + '//' + IntToStr(KK));
|
|
end;
|
|
typePOINTER:
|
|
begin
|
|
Add2(Tab(2) + 'RegisterPointerType(' +
|
|
StrLevelConst + ',' +
|
|
StrLiteral(RI.Name) + ',' +
|
|
GetStrTypeConst(RI.PatternId) +
|
|
');' + '//' + IntToStr(KK));
|
|
end;
|
|
typeSHORTSTRING:
|
|
begin
|
|
Add2(Tab(2) + 'RegisterShortstringType(' +
|
|
StrLevelConst + ',' +
|
|
StrLiteral(RI.Name) + ',' +
|
|
IntToStr(RI.Count) +
|
|
');' + '//' + IntToStr(KK));
|
|
end;
|
|
typePROC:
|
|
begin
|
|
Add2(Tab(2) + 'RegisterProceduralType(' +
|
|
StrLevelConst + ',' +
|
|
StrLiteral(RI.Name) + ',' +
|
|
'H_SUB' +
|
|
');' + '//' + IntToStr(KK));
|
|
end;
|
|
typeEVENT:
|
|
begin
|
|
Add2(Tab(2) + 'RegisterEventType(' +
|
|
StrLevelConst + ',' +
|
|
StrLiteral(RI.Name) + ',' +
|
|
'H_SUB' +
|
|
');' + '//' + IntToStr(KK));
|
|
end;
|
|
else
|
|
begin
|
|
if RI.TypeID = typeALIAS then
|
|
begin
|
|
Add2(Tab(2) + 'RegisterTypeAlias(' +
|
|
StrLevelConst + ',' +
|
|
StrLiteral(RI.Name) + ',' +
|
|
GetStrTypeConst(RI.PatternId) +
|
|
');' + '//' + IntToStr(KK));
|
|
continue;
|
|
end;
|
|
|
|
if (GTable[I + 1].Kind = kindCONST) and (GTable[I + 2].Kind = kindCONST) then
|
|
begin // subrange type
|
|
Add2(Tab(2) + 'RegisterSubrangeType(' +
|
|
StrLevelConst + ',' +
|
|
StrLiteral(RI.Name) + ',' +
|
|
GetStrTypeConst(RI.TypeId) + ',' +
|
|
IntToStr(GTable.GetLowBoundRec(I).Value) + ',' +
|
|
IntToStr(GTable.GetHighBoundRec(I).Value) +
|
|
');' + '//' + IntToStr(KK));
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
AddLine('{$O-}');
|
|
|
|
AddLine('////////////////////////////////////////////////////////////////////////////');
|
|
AddLine('// PaxCompiler import unit');
|
|
AddLine('// The unit has been generated by paxCompiler importer');
|
|
AddLine('// Site: http://www.paxcompiler.com');
|
|
AddLine('// Author: Alexander Baranovsky (paxscript@gmail.com)');
|
|
AddLine('// ========================================================================');
|
|
AddLine('// Copyright (c) Alexander Baranovsky, 2006-2008. All rights reserved.');
|
|
AddLine('////////////////////////////////////////////////////////////////////////////');
|
|
|
|
AddLine('unit ' + ImportUnitName + ';');
|
|
AddLine('interface');
|
|
AddUnits;
|
|
|
|
AddLine('procedure ' + RegProcName + ';');
|
|
AddLine('implementation');
|
|
|
|
for I:=0 to L1.Count - 1 do
|
|
AddLine(L1[I]);
|
|
|
|
for I:=0 to LP.Count - 1 do
|
|
AddLine(LP[I]);
|
|
|
|
AddLine('var H_NS, H_TYPE, H_SUB, H_READ, H_WRITE: Integer;');
|
|
AddLine('var Undefined: Variant;');
|
|
|
|
K := 1;
|
|
|
|
AddLine('procedure P1;');
|
|
AddLine('begin');
|
|
|
|
for I:=0 to L2.Count - 1 do
|
|
begin
|
|
if I > 0 then if I mod MaxLines = 0 then
|
|
begin
|
|
AddLine('end;');
|
|
Inc(K);
|
|
AddLine('procedure P' + IntToStr(K) + ';');
|
|
AddLine('begin');
|
|
end;
|
|
|
|
AddLine(L2[I]);
|
|
end;
|
|
AddLine('end;');
|
|
|
|
AddLine('procedure ' + RegProcName + ';');
|
|
AddLine('begin');
|
|
|
|
for I:=1 to K do
|
|
AddLine(Tab(2) + 'P' + IntToStr(I) + '();');
|
|
|
|
for I:=0 to RegisteredClasses.Count - 1 do
|
|
begin
|
|
J := Integer(RegisteredClasses.Objects[I]);
|
|
AddLine(Tab(2) + 'RegisterClassTypeInfos(' +
|
|
IntToStr(J) + ',' +
|
|
RegisteredClasses[I] +
|
|
');');
|
|
end;
|
|
|
|
AddLine('end;');
|
|
|
|
AddLine('initialization');
|
|
AddLine(' ' + RegProcName + ';');
|
|
AddLine('end.');
|
|
|
|
finally
|
|
NewKernel.Free;
|
|
|
|
L1.Free;
|
|
L2.Free;
|
|
LU.Free;
|
|
LP.Free;
|
|
|
|
RegisteredClasses.Free;
|
|
end;
|
|
end;
|
|
|
|
|
|
end.
|