mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-24 23:29:15 +02:00
pastojs: corba interfaces
git-svn-id: trunk@38651 -
This commit is contained in:
Mattias Gaertner
parent
c2a69bb9ca
commit
6af36d84ce
File diff suppressed because it is too large
Load Diff
@ -68,9 +68,11 @@ uses
|
||||
const
|
||||
PCUMagic = 'Pas2JSCache';
|
||||
PCUVersion = 2;
|
||||
// Version Changes:
|
||||
// 1: initial version
|
||||
// 2: TPasProperty.ImplementsFunc -> Implements array
|
||||
{ Version Changes:
|
||||
1: initial version
|
||||
2: - TPasProperty.ImplementsFunc:String -> Implements:TPasExprArray
|
||||
- pcsfAncestorResolved
|
||||
}
|
||||
|
||||
BuiltInNodeName = 'BuiltIn';
|
||||
|
||||
@ -341,6 +343,11 @@ const
|
||||
'DispInterface'
|
||||
);
|
||||
|
||||
PCUClassInterfaceTypeNames: array[TPasClassInterfaceType] of string = (
|
||||
'COM',
|
||||
'CORBA'
|
||||
);
|
||||
|
||||
PCUClassScopeFlagNames: array[TPasClassScopeFlag] of string = (
|
||||
'AncestorResolved',
|
||||
'Sealed',
|
||||
@ -558,6 +565,7 @@ type
|
||||
|
||||
TPCUFiler = class
|
||||
private
|
||||
FFileVersion: longint;
|
||||
FGUID: TGUID;
|
||||
FInitialFlags: TPCUInitialFlags;
|
||||
FOnGetSrc: TPCUGetSrcEvent;
|
||||
@ -661,7 +669,7 @@ type
|
||||
function CheckElScope(El: TPasElement; NotNilId: int64; ScopeClass: TPasScopeClass): TPasScope; virtual;
|
||||
procedure AddArrayFlag(Obj: TJSONObject; var Arr: TJSONArray;
|
||||
const ArrName, Flag: string; Enable: boolean);
|
||||
procedure AddReferenceToArray(Arr: TJSONArray; El: TPasElement); virtual;
|
||||
procedure AddReferenceToArray(Arr: TJSONArray; El: TPasElement; WriteNull: boolean = true); virtual;
|
||||
procedure AddReferenceToObj(Obj: TJSONObject; const PropName: string;
|
||||
El: TPasElement; WriteNil: boolean = false); virtual;
|
||||
procedure CreateElReferenceId(Ref: TPCUFilerElementRef); virtual;
|
||||
@ -732,6 +740,7 @@ type
|
||||
procedure WriteRecordTypeScope(Obj: TJSONObject; Scope: TPasRecordScope; aContext: TPCUWriterContext); virtual;
|
||||
procedure WriteRecordType(Obj: TJSONObject; El: TPasRecordType; aContext: TPCUWriterContext); virtual;
|
||||
procedure WriteClassScopeFlags(Obj: TJSONObject; const PropName: string; const Value, DefaultValue: TPasClassScopeFlags); virtual;
|
||||
procedure WriteClassIntfMapProcs(Obj: TJSONObject; Map: TPasClassIntfMap); virtual;
|
||||
procedure WriteClassScope(Obj: TJSONObject; Scope: TPas2JSClassScope; aContext: TPCUWriterContext); virtual;
|
||||
procedure WriteClassType(Obj: TJSONObject; El: TPasClassType; aContext: TPCUWriterContext); virtual;
|
||||
procedure WriteArgument(Obj: TJSONObject; El: TPasArgument; aContext: TPCUWriterContext); virtual;
|
||||
@ -745,6 +754,7 @@ type
|
||||
procedure WriteConst(Obj: TJSONObject; El: TPasConst; aContext: TPCUWriterContext); virtual;
|
||||
procedure WritePropertyScope(Obj: TJSONObject; Scope: TPasPropertyScope; aContext: TPCUWriterContext); virtual;
|
||||
procedure WriteProperty(Obj: TJSONObject; El: TPasProperty; aContext: TPCUWriterContext); virtual;
|
||||
procedure WriteMethodResolution(Obj: TJSONObject; El: TPasMethodResolution; aContext: TPCUWriterContext); virtual;
|
||||
procedure WriteProcedureModifiers(Obj: TJSONObject; const PropName: string; const Value, DefaultValue: TProcedureModifiers); virtual;
|
||||
procedure WriteProcScopeFlags(Obj: TJSONObject; const PropName: string; const Value, DefaultValue: TPasProcedureScopeFlags); virtual;
|
||||
procedure WriteProcedureScope(Obj: TJSONObject; Scope: TPas2JSProcedureScope; aContext: TPCUWriterContext); virtual;
|
||||
@ -804,7 +814,6 @@ type
|
||||
TPCUReader = class(TPCUCustomReader)
|
||||
private
|
||||
FElementRefsArray: TPCUFilerElementRefArray; // TPCUFilerElementRef by Id
|
||||
FFileVersion: longint;
|
||||
FJSON: TJSONObject;
|
||||
FPendingIdentifierScopes: TObjectList; // list of TPCUReaderPendingIdentifierScope
|
||||
procedure Set_Variable_VarType(RefEl: TPasElement; Data: TObject);
|
||||
@ -820,6 +829,7 @@ type
|
||||
procedure Set_ClassScope_NewInstanceFunction(RefEl: TPasElement; Data: TObject);
|
||||
procedure Set_ClassScope_DirectAncestor(RefEl: TPasElement; Data: TObject);
|
||||
procedure Set_ClassScope_DefaultProperty(RefEl: TPasElement; Data: TObject);
|
||||
procedure Set_ClassIntfMap_Intf(RefEl: TPasElement; Data: TObject);
|
||||
procedure Set_ClassType_AncestorType(RefEl: TPasElement; Data: TObject);
|
||||
procedure Set_ClassType_HelperForType(RefEl: TPasElement; Data: TObject);
|
||||
procedure Set_ResultElement_ResultType(RefEl: TPasElement; Data: TObject);
|
||||
@ -854,6 +864,7 @@ type
|
||||
procedure ReadHeaderMagic(Obj: TJSONObject); virtual;
|
||||
procedure ReadHeaderVersion(Obj: TJSONObject); virtual;
|
||||
procedure ReadGUID(Obj: TJSONObject); virtual;
|
||||
procedure ReadHeaderItem(const PropName: string; Data: TJSONData); virtual;
|
||||
procedure ReadArrayFlags(Data: TJSONData; El: TPasElement; const PropName: string; out Names: TStringDynArray; out Enable: TBooleanDynArray);
|
||||
function ReadParserOptions(Obj: TJSONObject; El: TPasElement; const PropName: string; const DefaultValue: TPOptions): TPOptions; virtual;
|
||||
function ReadModeSwitches(Obj: TJSONObject; El: TPasElement; const PropName: string; const DefaultValue: TModeSwitches): TModeSwitches; virtual;
|
||||
@ -923,9 +934,13 @@ type
|
||||
procedure ReadRecordVariant(Obj: TJSONObject; El: TPasVariant; aContext: TPCUReaderContext); virtual;
|
||||
procedure ReadRecordScope(Obj: TJSONObject; Scope: TPasRecordScope; aContext: TPCUReaderContext); virtual;
|
||||
procedure ReadRecordType(Obj: TJSONObject; El: TPasRecordType; aContext: TPCUReaderContext); virtual;
|
||||
function ReadClassInterfaceType(Obj: TJSONObject; const PropName: string; ErrorEl: TPasElement; DefaultValue: TPasClassInterfaceType): TPasClassInterfaceType;
|
||||
function ReadClassScopeFlags(Obj: TJSONObject; El: TPasElement;
|
||||
const PropName: string; const DefaultValue: TPasClassScopeFlags): TPasClassScopeFlags; virtual;
|
||||
procedure ReadClassScopeAbstractProcs(Obj: TJSONObject; Scope: TPas2JSClassScope); virtual;
|
||||
procedure ReadClassIntfMapProcs(Obj: TJSONObject; Map: TPasClassIntfMap; OrigIntfType: TPasType); virtual;
|
||||
procedure ReadClassIntfMap(Obj: TJSONObject; Scope: TPas2JSClassScope; Map: TPasClassIntfMap; OrigIntfType: TPasType); virtual;
|
||||
procedure ReadClassScopeInterfaces(Obj: TJSONObject; Scope: TPas2JSClassScope); virtual;
|
||||
procedure ReadClassScope(Obj: TJSONObject; Scope: TPas2JSClassScope; aContext: TPCUReaderContext); virtual;
|
||||
procedure ReadClassType(Obj: TJSONObject; El: TPasClassType; aContext: TPCUReaderContext); virtual;
|
||||
procedure ReadArgument(Obj: TJSONObject; El: TPasArgument; aContext: TPCUReaderContext); virtual;
|
||||
@ -942,6 +957,7 @@ type
|
||||
procedure ReadConst(Obj: TJSONObject; El: TPasConst; aContext: TPCUReaderContext); virtual;
|
||||
procedure ReadPropertyScope(Obj: TJSONObject; Scope: TPasPropertyScope; aContext: TPCUReaderContext); virtual;
|
||||
procedure ReadProperty(Obj: TJSONObject; El: TPasProperty; aContext: TPCUReaderContext); virtual;
|
||||
procedure ReadMethodResolution(Obj: TJSONObject; El: TPasMethodResolution; aContext: TPCUReaderContext); virtual;
|
||||
function ReadProcedureModifiers(Obj: TJSONObject; El: TPasElement;
|
||||
const PropName: string; const DefaultValue: TProcedureModifiers): TProcedureModifiers; virtual;
|
||||
function ReadProcScopeFlags(Obj: TJSONObject; El: TPasElement;
|
||||
@ -1644,9 +1660,18 @@ end;
|
||||
|
||||
function TPCUFiler.GetDefaultMemberVisibility(El: TPasElement
|
||||
): TPasMemberVisibility;
|
||||
var
|
||||
aClass: TPasClassType;
|
||||
begin
|
||||
if El=nil then ;
|
||||
Result:=visDefault;
|
||||
if El.Parent is TPasClassType then
|
||||
begin
|
||||
aClass:=TPasClassType(El.Parent);
|
||||
case aClass.ObjKind of
|
||||
okInterface: Result:=visPublic;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TPCUFiler.GetDefaultPasScopeVisibilityContext(Scope: TPasScope
|
||||
@ -1677,7 +1702,10 @@ end;
|
||||
function TPCUFiler.GetDefaultClassScopeFlags(Scope: TPas2JSClassScope
|
||||
): TPasClassScopeFlags;
|
||||
begin
|
||||
Result:=[];
|
||||
if FFileVersion<2 then
|
||||
Result:=[]
|
||||
else
|
||||
Result:=[pcsfAncestorResolved];
|
||||
if Scope.AncestorScope<>nil then
|
||||
begin
|
||||
if pcsfPublished in Scope.AncestorScope.Flags then
|
||||
@ -1786,6 +1814,7 @@ end;
|
||||
|
||||
constructor TPCUFiler.Create;
|
||||
begin
|
||||
FFileVersion:=PCUVersion;
|
||||
FSourceFiles:=TObjectList.Create(true);
|
||||
FElementRefs:=TAVLTree.Create(@ComparePCUFilerElementRef);
|
||||
FElementRefs.SetNodeManager(TAVLTreeNodeMemManager.Create,true); // no shared manager, needed for multithreading
|
||||
@ -1911,12 +1940,18 @@ begin
|
||||
Arr.Add('-'+Flag);
|
||||
end;
|
||||
|
||||
procedure TPCUWriter.AddReferenceToArray(Arr: TJSONArray; El: TPasElement);
|
||||
procedure TPCUWriter.AddReferenceToArray(Arr: TJSONArray; El: TPasElement;
|
||||
WriteNull: boolean);
|
||||
var
|
||||
Ref: TPCUFilerElementRef;
|
||||
Item: TPCUWriterPendingElRefArray;
|
||||
begin
|
||||
if El=nil then exit;
|
||||
if El=nil then
|
||||
begin
|
||||
if WriteNull then
|
||||
Arr.Add(CreateJSON);
|
||||
exit;
|
||||
end;
|
||||
Ref:=GetElementReference(El);
|
||||
if (Ref.Obj<>nil) and (Ref.Id=0) then
|
||||
CreateElReferenceId(Ref);
|
||||
@ -2821,6 +2856,11 @@ begin
|
||||
Obj.Add('Type','Property');
|
||||
WriteProperty(Obj,TPasProperty(El),aContext);
|
||||
end
|
||||
else if C=TPasMethodResolution then
|
||||
begin
|
||||
Obj.Add('Type','MethodRes');
|
||||
WriteMethodResolution(Obj,TPasMethodResolution(El),aContext);
|
||||
end
|
||||
else if C.InheritsFrom(TPasProcedure) then
|
||||
begin
|
||||
if C.InheritsFrom(TPasOperator) then
|
||||
@ -3258,13 +3298,54 @@ begin
|
||||
AddArrayFlag(Obj,Arr,PropName,PCUClassScopeFlagNames[f],f in Value);
|
||||
end;
|
||||
|
||||
procedure TPCUWriter.WriteClassIntfMapProcs(Obj: TJSONObject;
|
||||
Map: TPasClassIntfMap);
|
||||
var
|
||||
Procs: TFPList;
|
||||
Arr: TJSONArray;
|
||||
i: Integer;
|
||||
begin
|
||||
Procs:=Map.Procs;
|
||||
if Procs<>nil then
|
||||
begin
|
||||
Arr:=TJSONArray.Create;
|
||||
Obj.Add('Procs',Arr);
|
||||
for i:=0 to Procs.Count-1 do
|
||||
AddReferenceToArray(Arr,TPasProcedure(Procs[i]));
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPCUWriter.WriteClassScope(Obj: TJSONObject;
|
||||
Scope: TPas2JSClassScope; aContext: TPCUWriterContext);
|
||||
|
||||
procedure WriteMap(SubObj: TJSONObject; Map: TPasClassIntfMap);
|
||||
var
|
||||
AncObj: TJSONObject;
|
||||
begin
|
||||
if Map.Element=nil then
|
||||
RaiseMsg(20180325131134,Scope.Element);
|
||||
if Map.Intf=nil then
|
||||
RaiseMsg(20180325131135,Scope.Element);
|
||||
AddReferenceToObj(SubObj,'Intf',Map.Intf);
|
||||
WriteClassIntfMapProcs(SubObj,Map);
|
||||
if Map.AncestorMap<>nil then
|
||||
begin
|
||||
AncObj:=TJSONObject.Create;
|
||||
SubObj.Add('AncestorMap',AncObj);
|
||||
WriteMap(AncObj,Map.AncestorMap);
|
||||
end;
|
||||
end;
|
||||
|
||||
var
|
||||
Arr: TJSONArray;
|
||||
i: Integer;
|
||||
aClass: TPasClassType;
|
||||
CanonicalClassOf: TPasClassOfType;
|
||||
{$IFDEF EnableInterfaces}
|
||||
ScopeIntf: TFPList;
|
||||
o: TObject;
|
||||
SubObj: TJSONObject;
|
||||
{$ENDIF}
|
||||
begin
|
||||
WriteIdentifierScope(Obj,Scope,aContext);
|
||||
aClass:=Scope.Element as TPasClassType;
|
||||
@ -3272,16 +3353,23 @@ begin
|
||||
// AncestorScope can be derived from DirectAncestor
|
||||
// CanonicalClassOf is autogenerated
|
||||
CanonicalClassOf:=Scope.CanonicalClassOf;
|
||||
if CanonicalClassOf.Name<>'Self' then
|
||||
RaiseMsg(20180217143822,aClass);
|
||||
if CanonicalClassOf.DestType<>aClass then
|
||||
RaiseMsg(20180217143834,aClass);
|
||||
if CanonicalClassOf.Visibility<>visStrictPrivate then
|
||||
RaiseMsg(20180217143844,aClass);
|
||||
if CanonicalClassOf.SourceFilename<>aClass.SourceFilename then
|
||||
RaiseMsg(20180217143857,aClass);
|
||||
if CanonicalClassOf.SourceLinenumber<>aClass.SourceLinenumber then
|
||||
RaiseMsg(20180217143905,aClass);
|
||||
if aClass.ObjKind=okClass then
|
||||
begin
|
||||
if CanonicalClassOf=nil then
|
||||
RaiseMsg(20180217143821,aClass);
|
||||
if CanonicalClassOf.Name<>'Self' then
|
||||
RaiseMsg(20180217143822,aClass);
|
||||
if CanonicalClassOf.DestType<>aClass then
|
||||
RaiseMsg(20180217143834,aClass);
|
||||
if CanonicalClassOf.Visibility<>visStrictPrivate then
|
||||
RaiseMsg(20180217143844,aClass);
|
||||
if CanonicalClassOf.SourceFilename<>aClass.SourceFilename then
|
||||
RaiseMsg(20180217143857,aClass);
|
||||
if CanonicalClassOf.SourceLinenumber<>aClass.SourceLinenumber then
|
||||
RaiseMsg(20180217143905,aClass);
|
||||
end
|
||||
else if CanonicalClassOf<>nil then
|
||||
RaiseMsg(20180329110817,aClass,GetObjName(CanonicalClassOf));
|
||||
|
||||
AddReferenceToObj(Obj,'DirectAncestor',Scope.DirectAncestor);
|
||||
AddReferenceToObj(Obj,'DefaultProperty',Scope.DefaultProperty);
|
||||
@ -3294,6 +3382,36 @@ begin
|
||||
for i:=0 to length(Scope.AbstractProcs)-1 do
|
||||
AddReferenceToArray(Arr,Scope.AbstractProcs[i]);
|
||||
end;
|
||||
|
||||
{$IFDEF EnableInterfaces}
|
||||
if Scope.GUID<>'' then
|
||||
Obj.Add('SGUID',Scope.GUID);
|
||||
|
||||
ScopeIntf:=Scope.Interfaces;
|
||||
if (ScopeIntf<>nil) and (ScopeIntf.Count>0) then
|
||||
begin
|
||||
Arr:=TJSONArray.Create;
|
||||
Obj.Add('SInterfaces',Arr);
|
||||
for i:=0 to ScopeIntf.Count-1 do
|
||||
begin
|
||||
o:=TObject(ScopeIntf[i]);
|
||||
if o is TPasProperty then
|
||||
begin
|
||||
// delegation
|
||||
AddReferenceToArray(Arr,TPasProperty(o));
|
||||
end
|
||||
else if o is TPasClassIntfMap then
|
||||
begin
|
||||
// method resolution
|
||||
SubObj:=TJSONObject.Create;
|
||||
Arr.Add(SubObj);
|
||||
WriteMap(SubObj,TPasClassIntfMap(o));
|
||||
end
|
||||
else
|
||||
RaiseMsg(20180325111939,aClass,IntToStr(i)+':'+GetObjName(TObject(aClass.Interfaces[i]))+' '+GetObjName(o));
|
||||
end;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TPCUWriter.WriteClassType(Obj: TJSONObject; El: TPasClassType;
|
||||
@ -3308,6 +3426,8 @@ begin
|
||||
if El.PackMode<>pmNone then
|
||||
Obj.Add('Packed',PCUPackModeNames[El.PackMode]);
|
||||
// ObjKind is the 'Type'
|
||||
if El.InterfaceType<>citCom then
|
||||
Obj.Add('IntfType',PCUClassInterfaceTypeNames[El.InterfaceType]);
|
||||
WriteElType(Obj,El,'Ancestor',El.AncestorType,aContext);
|
||||
WriteElType(Obj,El,'HelperFor',El.HelperForType,aContext);
|
||||
if El.IsForward then
|
||||
@ -3479,6 +3599,21 @@ begin
|
||||
Obj.Add('Scope',false); // msIgnoreInterfaces
|
||||
end;
|
||||
|
||||
procedure TPCUWriter.WriteMethodResolution(Obj: TJSONObject;
|
||||
El: TPasMethodResolution; aContext: TPCUWriterContext);
|
||||
begin
|
||||
WritePasElement(Obj,El,aContext);
|
||||
if El.ProcClass=TPasProcedure then
|
||||
Obj.Add('ProcClass','procedure')
|
||||
else if El.ProcClass=TPasFunction then
|
||||
// default value
|
||||
else
|
||||
RaiseMsg(20180329104205,El);
|
||||
WriteExpr(Obj,El,'InterfaceName',El.InterfaceName,aContext);
|
||||
WriteExpr(Obj,El,'InterfaceProc',El.InterfaceProc,aContext);
|
||||
WriteExpr(Obj,El,'ImplementationProc',El.ImplementationProc,aContext);
|
||||
end;
|
||||
|
||||
procedure TPCUWriter.WriteProcedureModifiers(Obj: TJSONObject;
|
||||
const PropName: string; const Value, DefaultValue: TProcedureModifiers);
|
||||
var
|
||||
@ -4063,6 +4198,16 @@ begin
|
||||
RaiseMsg(20180214115044,Scope.Element,GetObjName(RefEl));
|
||||
end;
|
||||
|
||||
procedure TPCUReader.Set_ClassIntfMap_Intf(RefEl: TPasElement; Data: TObject);
|
||||
var
|
||||
Map: TPasClassIntfMap absolute Data;
|
||||
begin
|
||||
if RefEl is TPasClassType then
|
||||
Map.Intf:=TPasClassType(RefEl) // no AddRef
|
||||
else
|
||||
RaiseMsg(20180325125418,Map.Element,GetObjName(RefEl));
|
||||
end;
|
||||
|
||||
procedure TPCUReader.Set_ClassType_AncestorType(RefEl: TPasElement;
|
||||
Data: TObject);
|
||||
var
|
||||
@ -4520,6 +4665,11 @@ begin
|
||||
FGUID:=StringToGUID(s);
|
||||
end;
|
||||
|
||||
procedure TPCUReader.ReadHeaderItem(const PropName: string; Data: TJSONData);
|
||||
begin
|
||||
RaiseMsg(20180202151706,'unknown property "'+PropName+'" '+GetObjName(Data));
|
||||
end;
|
||||
|
||||
procedure TPCUReader.ReadArrayFlags(Data: TJSONData; El: TPasElement;
|
||||
const PropName: string; out Names: TStringDynArray; out
|
||||
Enable: TBooleanDynArray);
|
||||
@ -5450,6 +5600,11 @@ begin
|
||||
Result:=TPasProperty.Create(Name,Parent);
|
||||
ReadProperty(Obj,TPasProperty(Result),aContext);
|
||||
end;
|
||||
'MethodRes':
|
||||
begin
|
||||
Result:=TPasMethodResolution.Create(Name,Parent);
|
||||
ReadMethodResolution(Obj,TPasMethodResolution(Result),aContext);
|
||||
end;
|
||||
'Procedure': ReadProc(TPasProcedure,Name);
|
||||
'ClassProcedure': ReadProc(TPasClassProcedure,Name);
|
||||
'Function': ReadProc(TPasFunction,Name);
|
||||
@ -6347,6 +6502,24 @@ begin
|
||||
ReadRecordScope(Obj,Scope,aContext);
|
||||
end;
|
||||
|
||||
function TPCUReader.ReadClassInterfaceType(Obj: TJSONObject;
|
||||
const PropName: string; ErrorEl: TPasElement;
|
||||
DefaultValue: TPasClassInterfaceType): TPasClassInterfaceType;
|
||||
var
|
||||
s: string;
|
||||
cit: TPasClassInterfaceType;
|
||||
begin
|
||||
if ReadString(Obj,PropName,s,ErrorEl) then
|
||||
begin
|
||||
for cit in TPasClassInterfaceType do
|
||||
if s=PCUClassInterfaceTypeNames[cit] then
|
||||
exit(cit);
|
||||
RaiseMsg(20180329105126,ErrorEl,PropName+'='+s);
|
||||
end
|
||||
else
|
||||
Result:=DefaultValue;
|
||||
end;
|
||||
|
||||
function TPCUReader.ReadClassScopeFlags(Obj: TJSONObject; El: TPasElement;
|
||||
const PropName: string; const DefaultValue: TPasClassScopeFlags
|
||||
): TPasClassScopeFlags;
|
||||
@ -6414,6 +6587,146 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPCUReader.ReadClassIntfMapProcs(Obj: TJSONObject;
|
||||
Map: TPasClassIntfMap; OrigIntfType: TPasType);
|
||||
var
|
||||
aClass: TPasClassType;
|
||||
Arr: TJSONArray;
|
||||
i, Id: Integer;
|
||||
Data: TJSONData;
|
||||
IntfMember: TPasElement;
|
||||
Ref: TPCUFilerElementRef;
|
||||
begin
|
||||
aClass:=Map.Element as TPasClassType;
|
||||
if ReadArray(Obj,'Procs',Arr,aClass) then
|
||||
begin
|
||||
if Map.Procs<>nil then
|
||||
RaiseMsg(20180329143122,aClass);
|
||||
Map.Procs:=TFPList.Create;
|
||||
if Arr.Count<>Map.Intf.Members.Count then
|
||||
RaiseMsg(20180325130318,aClass,Map.Intf.FullPath+' Expected='+IntToStr(Map.Intf.Members.Count)+', but found '+IntToStr(Arr.Count));
|
||||
for i:=0 to Arr.Count-1 do
|
||||
begin
|
||||
Data:=Arr[i];
|
||||
IntfMember:=TPasElement(Map.Intf.Members[i]);
|
||||
if (Data is TJSONIntegerNumber) then
|
||||
begin
|
||||
Id:=Data.AsInteger;
|
||||
Ref:=AddElReference(Id,aClass,nil);
|
||||
if Ref.Element=nil then
|
||||
RaiseMsg(20180325125930,aClass,'missing method resolution of interface '+OrigIntfType.Name);
|
||||
if not (Ref.Element is TPasProcedure) then
|
||||
RaiseMsg(20180325130108,aClass,'['+IntToStr(i)+']='+OrigIntfType.Name+'.'+GetObjName(IntfMember)+' method expected, but found '+GetObjName(Ref.Element));
|
||||
if not (IntfMember is TPasProcedure) then
|
||||
RaiseMsg(20180329134354,aClass,'['+IntToStr(i)+']='+OrigIntfType.Name+'.'+GetObjName(IntfMember)+' intf member is not method, mapped proc='+GetObjName(Ref.Element));
|
||||
Map.Procs.Add(Ref.Element);
|
||||
end
|
||||
else if Data is TJSONNull then
|
||||
begin
|
||||
if IntfMember is TPasProcedure then
|
||||
RaiseMsg(20180329132957,aClass,'['+IntToStr(i)+']='+OrigIntfType.Name+'.'+GetObjName(IntfMember)+' intf method expects implementation');
|
||||
Map.Procs.Add(nil);
|
||||
end
|
||||
else
|
||||
RaiseMsg(20180325125851,aClass,IntToStr(i)+' '+GetObjName(Data));
|
||||
end;
|
||||
end
|
||||
else if Map.Intf.Members.Count>0 then
|
||||
RaiseMsg(20180325130720,aClass,Map.Intf.FullPath+' Expected='+IntToStr(Map.Intf.Members.Count)+', but found 0');
|
||||
end;
|
||||
|
||||
procedure TPCUReader.ReadClassIntfMap(Obj: TJSONObject; Scope: TPas2JSClassScope;
|
||||
Map: TPasClassIntfMap; OrigIntfType: TPasType);
|
||||
var
|
||||
aClass: TPasClassType;
|
||||
Id: Integer;
|
||||
Data: TJSONData;
|
||||
Ref: TPCUFilerElementRef;
|
||||
AncObj: TJSONObject;
|
||||
begin
|
||||
aClass:=Scope.Element as TPasClassType;
|
||||
Map.Element:=aClass;
|
||||
|
||||
// Intf
|
||||
Data:=Obj.Find('Intf');
|
||||
if not (Data is TJSONIntegerNumber) then
|
||||
RaiseMsg(20180325130226,aClass,OrigIntfType.Name);
|
||||
Id:=Data.AsInteger;
|
||||
Ref:=AddElReference(Id,aClass,nil);
|
||||
if not (Ref.Element is TPasClassType) then
|
||||
RaiseMsg(20180325131020,aClass,OrigIntfType.Name+' '+GetObjName(Ref.Element));
|
||||
Map.Intf:=TPasClassType(Ref.Element);
|
||||
|
||||
// Procs
|
||||
ReadClassIntfMapProcs(Obj,Map,OrigIntfType);
|
||||
|
||||
// AncestorMap
|
||||
if ReadObject(Obj,'AncestorMap',AncObj,aClass) then
|
||||
begin
|
||||
Map.AncestorMap:=TPasClassIntfMap.Create;
|
||||
ReadClassIntfMap(AncObj,Scope,Map.AncestorMap,OrigIntfType);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPCUReader.ReadClassScopeInterfaces(Obj: TJSONObject;
|
||||
Scope: TPas2JSClassScope);
|
||||
var
|
||||
aClass: TPasClassType;
|
||||
Arr: TJSONArray;
|
||||
i, Id: Integer;
|
||||
Data: TJSONData;
|
||||
Ref: TPCUFilerElementRef;
|
||||
OrigIntfType, IntfType: TPasType;
|
||||
SubObj: TJSONObject;
|
||||
Map: TPasClassIntfMap;
|
||||
begin
|
||||
aClass:=Scope.Element as TPasClassType;
|
||||
if ReadArray(Obj,'SInterfaces',Arr,aClass) then
|
||||
begin
|
||||
if Arr.Count<>aClass.Interfaces.Count then
|
||||
RaiseMsg(20180325124134,aClass);
|
||||
if Scope.Interfaces=nil then
|
||||
Scope.Interfaces:=TFPList.Create;
|
||||
if Scope.Interfaces.Count>0 then
|
||||
RaiseMsg(20180325124546,aClass);
|
||||
for i:=0 to Arr.Count-1 do
|
||||
begin
|
||||
OrigIntfType:=TPasType(aClass.Interfaces[i]);
|
||||
IntfType:=Resolver.ResolveAliasType(OrigIntfType);
|
||||
if not (IntfType is TPasClassType) then
|
||||
RaiseMsg(20180325124401,aClass,IntToStr(i)+' '+GetObjName(IntfType));
|
||||
Data:=Arr[i];
|
||||
if Data is TJSONIntegerNumber then
|
||||
begin
|
||||
// property, interface delegation
|
||||
Id:=Data.AsInteger;
|
||||
Ref:=AddElReference(Id,aClass,nil);
|
||||
if Ref.Element=nil then
|
||||
RaiseMsg(20180325124421,aClass,'missing delegation property of interface '+OrigIntfType.Name);
|
||||
if not (Ref.Element is TPasProperty) then
|
||||
RaiseMsg(20180325124616,aClass,OrigIntfType.Name+' delegate: '+GetObjName(Ref.Element));
|
||||
Scope.Interfaces.Add(Ref.Element);
|
||||
end
|
||||
else if Data is TJSONObject then
|
||||
begin
|
||||
// map
|
||||
SubObj:=TJSONObject(Data);
|
||||
Map:=TPasClassIntfMap.Create;
|
||||
Scope.Interfaces.Add(Map);
|
||||
ReadClassIntfMap(SubObj,Scope,Map,OrigIntfType);
|
||||
end
|
||||
else
|
||||
RaiseMsg(20180325124206,aClass,OrigIntfType.Name);
|
||||
end;
|
||||
end
|
||||
else if aClass.Interfaces.Count>0 then
|
||||
begin
|
||||
{$IFDEF EnableInterfaces}
|
||||
RaiseMsg(20180325131248,aClass);
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPCUReader.ReadClassScope(Obj: TJSONObject; Scope: TPas2JSClassScope;
|
||||
aContext: TPCUReaderContext);
|
||||
var
|
||||
@ -6422,18 +6735,23 @@ var
|
||||
begin
|
||||
aClass:=Scope.Element as TPasClassType;
|
||||
|
||||
CanonicalClassOf:=TPasClassOfType.Create('Self',aClass);
|
||||
Scope.CanonicalClassOf:=CanonicalClassOf;
|
||||
CanonicalClassOf.Visibility:=visStrictPrivate;
|
||||
CanonicalClassOf.SourceFilename:=aClass.SourceFilename;
|
||||
CanonicalClassOf.SourceLinenumber:=aClass.SourceLinenumber;
|
||||
CanonicalClassOf.DestType:=aClass;
|
||||
aClass.AddRef; // for the CanonicalClassOf.DestType
|
||||
if aClass.ObjKind=okClass then
|
||||
begin
|
||||
CanonicalClassOf:=TPasClassOfType.Create('Self',aClass);
|
||||
Scope.CanonicalClassOf:=CanonicalClassOf;
|
||||
CanonicalClassOf.Visibility:=visStrictPrivate;
|
||||
CanonicalClassOf.SourceFilename:=aClass.SourceFilename;
|
||||
CanonicalClassOf.SourceLinenumber:=aClass.SourceLinenumber;
|
||||
CanonicalClassOf.DestType:=aClass;
|
||||
aClass.AddRef; // for the CanonicalClassOf.DestType
|
||||
end;
|
||||
|
||||
ReadElementReference(Obj,Scope,'NewInstanceFunction',@Set_ClassScope_NewInstanceFunction);
|
||||
ReadElementReference(Obj,Scope,'DirectAncestor',@Set_ClassScope_DirectAncestor);
|
||||
ReadElementReference(Obj,Scope,'DefaultProperty',@Set_ClassScope_DefaultProperty);
|
||||
Scope.Flags:=ReadClassScopeFlags(Obj,Scope.Element,'SFlags',GetDefaultClassScopeFlags(Scope));
|
||||
if not ReadString(Obj,'SGUID',Scope.GUID,aClass) then
|
||||
Scope.GUID:='';
|
||||
|
||||
ReadIdentifierScope(Obj,Scope,aContext);
|
||||
end;
|
||||
@ -6470,6 +6788,9 @@ begin
|
||||
ReadPasElement(Obj,El,aContext);
|
||||
El.PackMode:=ReadPackedMode(Obj,'Packed',El);
|
||||
// ObjKind is the 'Type'
|
||||
|
||||
El.InterfaceType:=ReadClassInterfaceType(Obj,'IntfType',El,citCom);
|
||||
|
||||
ReadElType(Obj,'Ancestor',El,@Set_ClassType_AncestorType,aContext);
|
||||
ReadElType(Obj,'HelperFor',El,@Set_ClassType_HelperForType,aContext);
|
||||
ReadBoolean(Obj,'External',El.IsExternal,El);
|
||||
@ -6497,7 +6818,10 @@ begin
|
||||
// read Members
|
||||
ReadElementList(Obj,El,'Members',El.Members,true,aContext);
|
||||
if Scope<>nil then
|
||||
begin
|
||||
ReadClassScopeAbstractProcs(Obj,Scope);
|
||||
ReadClassScopeInterfaces(Obj,Scope);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPCUReader.ReadArgument(Obj: TJSONObject; El: TPasArgument;
|
||||
@ -6729,6 +7053,25 @@ begin
|
||||
ReadPropertyScope(Obj,Scope,aContext);
|
||||
end;
|
||||
|
||||
procedure TPCUReader.ReadMethodResolution(Obj: TJSONObject;
|
||||
El: TPasMethodResolution; aContext: TPCUReaderContext);
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
ReadPasElement(Obj,El,aContext);
|
||||
if ReadString(Obj,'ProcClass',s,El) then
|
||||
case s of
|
||||
'procedure': El.ProcClass:=TPasProcedure;
|
||||
else
|
||||
RaiseMsg(20180329104616,El,s);
|
||||
end
|
||||
else
|
||||
El.ProcClass:=TPasFunction;
|
||||
El.InterfaceProc:=ReadExpr(Obj,El,'InterfaceProc',aContext);
|
||||
El.InterfaceName:=ReadExpr(Obj,El,'InterfaceName',aContext);
|
||||
El.ImplementationProc:=ReadExpr(Obj,El,'ImplementationProc',aContext);
|
||||
end;
|
||||
|
||||
function TPCUReader.ReadProcedureModifiers(Obj: TJSONObject; El: TPasElement;
|
||||
const PropName: string; const DefaultValue: TProcedureModifiers
|
||||
): TProcedureModifiers;
|
||||
@ -7214,7 +7557,7 @@ begin
|
||||
'FinalBoolSwitches': Scanner.CurrentBoolSwitches:=ReadBoolSwitches(Obj,nil,aName,InitialFlags.BoolSwitches);
|
||||
'Module': ReadModuleHeader(Data);
|
||||
else
|
||||
RaiseMsg(20180202151706,'unknown property "'+aName+'"');
|
||||
ReadHeaderItem(aName,Data);
|
||||
end;
|
||||
end;
|
||||
{$IFDEF VerbosePCUFiler}
|
||||
|
||||
@ -116,6 +116,7 @@ type
|
||||
procedure CheckRestoredExportSymbol(const Path: string; Orig, Rest: TPasExportSymbol); virtual;
|
||||
procedure CheckRestoredConst(const Path: string; Orig, Rest: TPasConst); virtual;
|
||||
procedure CheckRestoredProperty(const Path: string; Orig, Rest: TPasProperty); virtual;
|
||||
procedure CheckRestoredMethodResolution(const Path: string; Orig, Rest: TPasMethodResolution); virtual;
|
||||
procedure CheckRestoredProcedure(const Path: string; Orig, Rest: TPasProcedure); virtual;
|
||||
procedure CheckRestoredOperator(const Path: string; Orig, Rest: TPasOperator); virtual;
|
||||
public
|
||||
@ -152,7 +153,11 @@ type
|
||||
procedure TestPC_ClassConstructor;
|
||||
procedure TestPC_Initialization;
|
||||
procedure TestPC_BoolSwitches;
|
||||
{$IFDEF EnableInterfaces}
|
||||
procedure TestPC_ClassInterface;
|
||||
{$ELSE}
|
||||
procedure TestPC_IgnoreInterface;
|
||||
{$ENDIF}
|
||||
procedure TestPC_IgnoreAttributes;
|
||||
|
||||
procedure TestPC_UseUnit;
|
||||
@ -692,7 +697,10 @@ end;
|
||||
procedure TCustomTestPrecompile.CheckRestoredClassScope(const Path: string;
|
||||
Orig, Rest: TPas2JSClassScope);
|
||||
var
|
||||
i: Integer;
|
||||
i, j: Integer;
|
||||
OrigObj, RestObj: TObject;
|
||||
OrigMap, RestMap: TPasClassIntfMap;
|
||||
SubPath: String;
|
||||
begin
|
||||
CheckRestoredScopeReference(Path+'.AncestorScope',Orig.AncestorScope,Rest.AncestorScope);
|
||||
CheckRestoredElement(Path+'.CanonicalClassOf',Orig.CanonicalClassOf,Rest.CanonicalClassOf);
|
||||
@ -703,7 +711,56 @@ begin
|
||||
AssertEquals(Path+'.AbstractProcs.length',length(Orig.AbstractProcs),length(Rest.AbstractProcs));
|
||||
for i:=0 to length(Orig.AbstractProcs)-1 do
|
||||
CheckRestoredReference(Path+'.AbstractProcs['+IntToStr(i)+']',Orig.AbstractProcs[i],Rest.AbstractProcs[i]);
|
||||
|
||||
CheckRestoredReference(Path+'.NewInstanceFunction',Orig.NewInstanceFunction,Rest.NewInstanceFunction);
|
||||
AssertEquals(Path+'.GUID',Orig.GUID,Rest.GUID);
|
||||
|
||||
CheckRestoredObject('.Interfaces',Orig.Interfaces,Rest.Interfaces);
|
||||
if Orig.Interfaces<>nil then
|
||||
begin
|
||||
AssertEquals(Path+'.Interfaces.Count',Orig.Interfaces.Count,Rest.Interfaces.Count);
|
||||
for i:=0 to Orig.Interfaces.Count-1 do
|
||||
begin
|
||||
SubPath:=Path+'.Interfaces['+IntToStr(i)+']';
|
||||
OrigObj:=TObject(Orig.Interfaces[i]);
|
||||
RestObj:=TObject(Rest.Interfaces[i]);
|
||||
CheckRestoredObject(SubPath,OrigObj,RestObj);
|
||||
if OrigObj is TPasProperty then
|
||||
CheckRestoredReference(SubPath+'(TPasProperty)',
|
||||
TPasProperty(OrigObj),TPasProperty(RestObj))
|
||||
else if OrigObj is TPasClassIntfMap then
|
||||
begin
|
||||
OrigMap:=TPasClassIntfMap(OrigObj);
|
||||
RestMap:=TPasClassIntfMap(RestObj);
|
||||
repeat
|
||||
AssertNotNull(SubPath+'.Intf Orig',OrigMap.Intf);
|
||||
CheckRestoredObject(SubPath+'.Intf',OrigMap.Intf,RestMap.Intf);
|
||||
SubPath:=SubPath+'.Map('+OrigMap.Intf.Name+')';
|
||||
CheckRestoredObject(SubPath+'.Element',OrigMap.Element,RestMap.Element);
|
||||
CheckRestoredObject(SubPath+'.Procs',OrigMap.Procs,RestMap.Procs);
|
||||
if OrigMap.Procs=nil then
|
||||
begin
|
||||
if OrigMap.Intf.Members.Count>0 then
|
||||
Fail(SubPath+' expected '+IntToStr(OrigMap.Intf.Members.Count)+' procs, but Procs=nil');
|
||||
end
|
||||
else
|
||||
for j:=0 to OrigMap.Procs.Count-1 do
|
||||
begin
|
||||
OrigObj:=TObject(OrigMap.Procs[j]);
|
||||
RestObj:=TObject(RestMap.Procs[j]);
|
||||
CheckRestoredReference(SubPath+'.Procs['+IntToStr(j)+']',TPasElement(OrigObj),TPasElement(RestObj));
|
||||
end;
|
||||
AssertEquals(Path+'.Procs.Count',OrigMap.Procs.Count,RestMap.Procs.Count);
|
||||
|
||||
CheckRestoredObject(SubPath+'.AncestorMap',OrigMap.AncestorMap,RestMap.AncestorMap);
|
||||
OrigMap:=OrigMap.AncestorMap;
|
||||
RestMap:=RestMap.AncestorMap;
|
||||
until OrigMap=nil;
|
||||
end
|
||||
else
|
||||
Fail(SubPath+' unknown class '+GetObjName(OrigObj));
|
||||
end;
|
||||
end;
|
||||
|
||||
CheckRestoredIdentifierScope(Path,Orig,Rest);
|
||||
end;
|
||||
@ -1066,6 +1123,8 @@ begin
|
||||
CheckRestoredConst(Path,TPasConst(Orig),TPasConst(Rest))
|
||||
else if C=TPasProperty then
|
||||
CheckRestoredProperty(Path,TPasProperty(Orig),TPasProperty(Rest))
|
||||
else if C=TPasMethodResolution then
|
||||
CheckRestoredMethodResolution(Path,TPasMethodResolution(Orig),TPasMethodResolution(Rest))
|
||||
else if (C=TPasProcedure)
|
||||
or (C=TPasFunction)
|
||||
or (C=TPasConstructor)
|
||||
@ -1109,6 +1168,7 @@ begin
|
||||
RestItem:=TObject(Rest[i]);
|
||||
if not (RestItem is TPasElement) then
|
||||
Fail(SubPath+' Rest='+GetObjName(RestItem));
|
||||
//writeln('TCustomTestPrecompile.CheckRestoredElementList ',GetObjName(OrigItem),' ',GetObjName(RestItem));
|
||||
SubPath:=Path+'['+IntToStr(i)+']"'+TPasElement(OrigItem).Name+'"';
|
||||
CheckRestoredElement(SubPath,TPasElement(OrigItem),TPasElement(RestItem));
|
||||
end;
|
||||
@ -1316,6 +1376,8 @@ begin
|
||||
Fail(Path+'.PackMode Orig='+PCUPackModeNames[Orig.PackMode]+' Rest='+PCUPackModeNames[Rest.PackMode]);
|
||||
if Orig.ObjKind<>Rest.ObjKind then
|
||||
Fail(Path+'.ObjKind Orig='+PCUObjKindNames[Orig.ObjKind]+' Rest='+PCUObjKindNames[Rest.ObjKind]);
|
||||
if Orig.InterfaceType<>Rest.InterfaceType then
|
||||
Fail(Path+'.ObjKind Orig='+PCUClassInterfaceTypeNames[Orig.InterfaceType]+' Rest='+PCUClassInterfaceTypeNames[Rest.InterfaceType]);
|
||||
CheckRestoredReference(Path+'.AncestorType',Orig.AncestorType,Rest.AncestorType);
|
||||
CheckRestoredReference(Path+'.HelperForType',Orig.HelperForType,Rest.HelperForType);
|
||||
AssertEquals(Path+'.IsForward',Orig.IsForward,Rest.IsForward);
|
||||
@ -1400,8 +1462,8 @@ begin
|
||||
CheckRestoredElement(Path+'.IndexExpr',Orig.IndexExpr,Rest.IndexExpr);
|
||||
CheckRestoredElement(Path+'.ReadAccessor',Orig.ReadAccessor,Rest.ReadAccessor);
|
||||
CheckRestoredElement(Path+'.WriteAccessor',Orig.WriteAccessor,Rest.WriteAccessor);
|
||||
CheckRestoredPasExprArray(Path+'.Implements',Orig.Implements,Rest.Implements);
|
||||
CheckRestoredElement(Path+'.DispIDExpr',Orig.DispIDExpr,Rest.DispIDExpr);
|
||||
CheckRestoredPasExprArray(Path+'.Implements',Orig.Implements,Rest.Implements);
|
||||
CheckRestoredElement(Path+'.StoredAccessor',Orig.StoredAccessor,Rest.StoredAccessor);
|
||||
CheckRestoredElement(Path+'.DefaultExpr',Orig.DefaultExpr,Rest.DefaultExpr);
|
||||
CheckRestoredElementList(Path+'.Args',Orig.Args,Rest.Args);
|
||||
@ -1412,6 +1474,15 @@ begin
|
||||
CheckRestoredVariable(Path,Orig,Rest);
|
||||
end;
|
||||
|
||||
procedure TCustomTestPrecompile.CheckRestoredMethodResolution(
|
||||
const Path: string; Orig, Rest: TPasMethodResolution);
|
||||
begin
|
||||
AssertEquals(Path+'.ProcClass',Orig.ProcClass,Rest.ProcClass);
|
||||
CheckRestoredElement(Path+'.InterfaceName',Orig.InterfaceName,Rest.InterfaceName);
|
||||
CheckRestoredElement(Path+'.InterfaceProc',Orig.InterfaceProc,Rest.InterfaceProc);
|
||||
CheckRestoredElement(Path+'.ImplementationProc',Orig.ImplementationProc,Rest.ImplementationProc);
|
||||
end;
|
||||
|
||||
procedure TCustomTestPrecompile.CheckRestoredProcedure(const Path: string;
|
||||
Orig, Rest: TPasProcedure);
|
||||
var
|
||||
@ -1889,6 +1960,44 @@ begin
|
||||
WriteReadUnit;
|
||||
end;
|
||||
|
||||
{$IFDEF EnableInterfaces}
|
||||
procedure TTestPrecompile.TestPC_ClassInterface;
|
||||
begin
|
||||
StartUnit(false);
|
||||
Add([
|
||||
'interface',
|
||||
'{$interfaces corba}',
|
||||
'type',
|
||||
' IUnknown = interface',
|
||||
' end;',
|
||||
' IFlying = interface',
|
||||
' procedure SetItems(Index: longint; Value: longint);',
|
||||
' end;',
|
||||
' IBird = interface(IFlying)',
|
||||
' [''{D44C1F80-44F9-4E88-8443-C518CCDC1FE8}'']',
|
||||
' function GetItems(Index: longint): longint;',
|
||||
' property Items[Index: longint]: longint read GetItems write SetItems;',
|
||||
' end;',
|
||||
' TObject = class',
|
||||
' end;',
|
||||
' TBird = class(TObject,IBird)',
|
||||
' strict private',
|
||||
' function IBird.GetItems = RetItems;',
|
||||
' function RetItems(Index: longint): longint; virtual; abstract;',
|
||||
' procedure SetItems(Index: longint; Value: longint); virtual; abstract;',
|
||||
' end;',
|
||||
' TEagle = class(TObject,IBird)',
|
||||
' strict private',
|
||||
' FBird: IBird;',
|
||||
' property Bird: IBird read FBird implements IBird;',
|
||||
' end;',
|
||||
'implementation',
|
||||
'end.',
|
||||
'']);
|
||||
WriteReadUnit;
|
||||
end;
|
||||
|
||||
{$ELSE}
|
||||
procedure TTestPrecompile.TestPC_IgnoreInterface;
|
||||
begin
|
||||
StartUnit(false);
|
||||
@ -1906,6 +2015,7 @@ begin
|
||||
'']);
|
||||
WriteReadUnit;
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
procedure TTestPrecompile.TestPC_IgnoreAttributes;
|
||||
begin
|
||||
|
||||
@ -257,6 +257,7 @@ type
|
||||
Procedure TestNestedForwardProc;
|
||||
Procedure TestAssignFunctionResult;
|
||||
Procedure TestFunctionResultInCondition;
|
||||
Procedure TestFunctionResultInForLoop;
|
||||
Procedure TestExit;
|
||||
Procedure TestBreak;
|
||||
Procedure TestBreakAsVar;
|
||||
@ -474,7 +475,22 @@ type
|
||||
Procedure TestExternalClass_BracketAccessor_Index;
|
||||
|
||||
// class interfaces
|
||||
{$IFDEF EnableInterfaces}
|
||||
Procedure TestClassInterface_Corba;
|
||||
Procedure TestClassInterface_ProcExternalFail;
|
||||
Procedure TestClassInterface_Overloads;
|
||||
Procedure TestClassInterface_AncestorImpl;
|
||||
Procedure TestClassInterface_ImplReintroduce;
|
||||
Procedure TestClassInterface_MethodResolution;
|
||||
Procedure TestClassInterface_Delegation;
|
||||
Procedure TestClassInterface_DelegationStatic;
|
||||
Procedure TestClassInterface_Operators;
|
||||
Procedure TestClassInterface_Args;
|
||||
Procedure TestClassInterface_ForInCorbaIntf;
|
||||
// ToDo: COM: _AddRef,_Release :=, pass as arg, IEnumerable
|
||||
{$ELSE}
|
||||
Procedure TestClassInterface_Ignore;
|
||||
{$ENDIF}
|
||||
|
||||
// proc types
|
||||
Procedure TestProcType;
|
||||
@ -566,6 +582,9 @@ type
|
||||
Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses2;
|
||||
Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses3;
|
||||
Procedure TestRTTI_TypeInfo_FunctionClassType;
|
||||
{$IFDEF EnableInterfaces}
|
||||
Procedure TestRTTI_Interface;
|
||||
{$ENDIF}
|
||||
|
||||
// Resourcestring
|
||||
Procedure TestResourcestringProgram;
|
||||
@ -2675,6 +2694,38 @@ begin
|
||||
]));
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestFunctionResultInForLoop;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'function Func1(a: array of longint): longint;',
|
||||
'begin',
|
||||
' for Result:=High(a) downto Low(a) do if a[Result]=0 then exit;',
|
||||
' for Result in a do if a[Result]=0 then exit;',
|
||||
'end;',
|
||||
'begin',
|
||||
' Func1([1,2,3])']);
|
||||
ConvertProgram;
|
||||
CheckSource('TestFunctionResultInForLoop',
|
||||
LinesToStr([ // statements
|
||||
'this.Func1 = function (a) {',
|
||||
' var Result = 0;',
|
||||
' for (var $l1 = rtl.length(a) - 1; $l1 >= 0; $l1--) {',
|
||||
' Result = $l1;',
|
||||
' if (a[Result] === 0) return Result;',
|
||||
' };',
|
||||
' for (var $in2 = a, $l3 = 0, $end4 = rtl.length($in2) - 1; $l3 <= $end4; $l3++) {',
|
||||
' Result = $in2[$l3];',
|
||||
' if (a[Result] === 0) return Result;',
|
||||
' };',
|
||||
' return Result;',
|
||||
'};',
|
||||
'']),
|
||||
LinesToStr([
|
||||
'$mod.Func1([1, 2, 3]);'
|
||||
]));
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestExit;
|
||||
begin
|
||||
StartProgram(false);
|
||||
@ -5704,17 +5755,19 @@ end;
|
||||
procedure TTestModule.TestAsmBlock;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add('var');
|
||||
Add(' vI: longint;');
|
||||
Add('begin');
|
||||
Add(' vi:=1;');
|
||||
Add(' asm');
|
||||
Add(' if (vI===1) {');
|
||||
Add(' vI=2;');
|
||||
Add(' }');
|
||||
Add(' if (vI===2){ vI=3; }');
|
||||
Add(' end;');
|
||||
Add(' VI:=4;');
|
||||
Add([
|
||||
'var',
|
||||
' vI: longint;',
|
||||
'begin',
|
||||
' vi:=1;',
|
||||
' asm',
|
||||
' if (vI===1) {',
|
||||
' vI=2;',
|
||||
//' console.log(''end;'');', ToDo
|
||||
' }',
|
||||
' if (vI===2){ vI=3; }',
|
||||
' end;',
|
||||
' VI:=4;']);
|
||||
ConvertProgram;
|
||||
CheckSource('TestAsmBlock',
|
||||
LinesToStr([ // statements
|
||||
@ -11934,39 +11987,53 @@ end;
|
||||
procedure TTestModule.TestExternalClass_TypeCastToRootClass;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add('{$modeswitch externalclass}');
|
||||
Add('type');
|
||||
Add(' TObject = class');
|
||||
Add(' end;');
|
||||
Add(' TChild = class');
|
||||
Add(' end;');
|
||||
Add(' TExtRootA = class external name ''ExtRootA''');
|
||||
Add(' end;');
|
||||
Add(' TExtChildA = class external name ''ExtChildA''(TExtRootA)');
|
||||
Add(' end;');
|
||||
Add(' TExtRootB = class external name ''ExtRootB''');
|
||||
Add(' end;');
|
||||
Add(' TExtChildB = class external name ''ExtChildB''(TExtRootB)');
|
||||
Add(' end;');
|
||||
Add('var');
|
||||
Add(' Obj: TObject;');
|
||||
Add(' Child: TChild;');
|
||||
Add(' RootA: TExtRootA;');
|
||||
Add(' ChildA: TExtChildA;');
|
||||
Add(' RootB: TExtRootB;');
|
||||
Add(' ChildB: TExtChildB;');
|
||||
Add('begin');
|
||||
Add(' obj:=tobject(roota);');
|
||||
Add(' obj:=tobject(childa);');
|
||||
Add(' child:=tchild(tobject(roota));');
|
||||
Add(' roota:=textroota(obj);');
|
||||
Add(' roota:=textroota(child);');
|
||||
Add(' roota:=textroota(rootb);');
|
||||
Add(' roota:=textroota(childb);');
|
||||
Add(' childa:=textchilda(textroota(obj));');
|
||||
Add([
|
||||
'{$modeswitch externalclass}',
|
||||
'type',
|
||||
{$IFDEF EnableInterfaces}
|
||||
' IUnknown = interface end;',
|
||||
{$ENDIF}
|
||||
' TObject = class',
|
||||
' end;',
|
||||
' TChild = class',
|
||||
' end;',
|
||||
' TExtRootA = class external name ''ExtRootA''',
|
||||
' end;',
|
||||
' TExtChildA = class external name ''ExtChildA''(TExtRootA)',
|
||||
' end;',
|
||||
' TExtRootB = class external name ''ExtRootB''',
|
||||
' end;',
|
||||
' TExtChildB = class external name ''ExtChildB''(TExtRootB)',
|
||||
' end;',
|
||||
'var',
|
||||
' Obj: TObject;',
|
||||
' Child: TChild;',
|
||||
' RootA: TExtRootA;',
|
||||
' ChildA: TExtChildA;',
|
||||
' RootB: TExtRootB;',
|
||||
' ChildB: TExtChildB;',
|
||||
{$IFDEF EnableInterfaces}
|
||||
' i: IUnknown;',
|
||||
{$ENDIF}
|
||||
'begin',
|
||||
' obj:=tobject(roota);',
|
||||
' obj:=tobject(childa);',
|
||||
' child:=tchild(tobject(roota));',
|
||||
' roota:=textroota(obj);',
|
||||
' roota:=textroota(child);',
|
||||
' roota:=textroota(rootb);',
|
||||
' roota:=textroota(childb);',
|
||||
' childa:=textchilda(textroota(obj));',
|
||||
{$IFDEF EnableInterfaces}
|
||||
' roota:=TExtRootA(i)',
|
||||
{$ENDIF}
|
||||
'']);
|
||||
ConvertProgram;
|
||||
CheckSource('TestExternalClass_TypeCastToRootClass',
|
||||
LinesToStr([ // statements
|
||||
{$IFDEF EnableInterfaces}
|
||||
'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E00-3000-8000-000000000000}", [], null);',
|
||||
{$ENDIF}
|
||||
'rtl.createClass($mod, "TObject", null, function () {',
|
||||
' this.$init = function () {',
|
||||
' };',
|
||||
@ -11981,6 +12048,9 @@ begin
|
||||
'this.ChildA = null;',
|
||||
'this.RootB = null;',
|
||||
'this.ChildB = null;',
|
||||
{$IFDEF EnableInterfaces}
|
||||
'this.i = null;',
|
||||
{$ENDIF}
|
||||
'']),
|
||||
LinesToStr([ // $mod.$main
|
||||
'$mod.Obj = $mod.RootA;',
|
||||
@ -11991,6 +12061,9 @@ begin
|
||||
'$mod.RootA = $mod.RootB;',
|
||||
'$mod.RootA = $mod.ChildB;',
|
||||
'$mod.ChildA = $mod.Obj;',
|
||||
{$IFDEF EnableInterfaces}
|
||||
'$mod.RootA = $mod.i;',
|
||||
{$ENDIF}
|
||||
'']));
|
||||
end;
|
||||
|
||||
@ -12271,6 +12344,711 @@ begin
|
||||
'']));
|
||||
end;
|
||||
|
||||
{$IFDEF EnableInterfaces}
|
||||
procedure TTestModule.TestClassInterface_Corba;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$interfaces corba}',
|
||||
'type',
|
||||
' IUnknown = interface;',
|
||||
' IUnknown = interface',
|
||||
' [''{00000000-0000-0000-C000-000000000046}'']',
|
||||
' end;',
|
||||
' IInterface = IUnknown;',
|
||||
' IBird = interface(IInterface)',
|
||||
' function GetSize: longint;',
|
||||
' procedure SetSize(i: longint);',
|
||||
' property Size: longint read GetSize write SetSize;',
|
||||
' procedure DoIt(i: longint);',
|
||||
' end;',
|
||||
' TObject = class',
|
||||
' end;',
|
||||
' TBird = class(TObject,IBird)',
|
||||
' function GetSize: longint; virtual; abstract;',
|
||||
' procedure SetSize(i: longint); virtual; abstract;',
|
||||
' procedure DoIt(i: longint); virtual; abstract;',
|
||||
' end;',
|
||||
'var',
|
||||
' BirdIntf: IBird;',
|
||||
'begin',
|
||||
' BirdIntf.Size:=BirdIntf.Size;',
|
||||
'']);
|
||||
ConvertProgram;
|
||||
CheckSource('TestClassInterface_Corba',
|
||||
LinesToStr([ // statements
|
||||
'rtl.createInterface($mod, "IUnknown", "{00000000-0000-0000-C000-000000000046}", [], null);',
|
||||
'rtl.createInterface($mod, "IBird", "{B0AF836B-4E58-31BA-A735-D744B6DAA205}", ["GetSize", "SetSize", "DoIt"], $mod.IUnknown);',
|
||||
'rtl.createClass($mod, "TObject", null, function () {',
|
||||
' this.$init = function () {',
|
||||
' };',
|
||||
' this.$final = function () {',
|
||||
' };',
|
||||
'});',
|
||||
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
||||
' this.$intfmaps = {};',
|
||||
' rtl.addIntf(this, $mod.IBird);',
|
||||
'});',
|
||||
'this.BirdIntf = null;',
|
||||
'']),
|
||||
LinesToStr([ // $mod.$main
|
||||
' $mod.BirdIntf.SetSize($mod.BirdIntf.GetSize());',
|
||||
'']));
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestClassInterface_ProcExternalFail;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$interfaces corba}',
|
||||
'type',
|
||||
' IUnknown = interface',
|
||||
' procedure DoIt; external name ''foo'';',
|
||||
' end;',
|
||||
'begin']);
|
||||
SetExpectedParserError(
|
||||
'Fields are not allowed in Interfaces at token "Identifier external" in file test1.pp at line 6 column 21',
|
||||
nParserNoFieldsAllowed);
|
||||
ConvertProgram;
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestClassInterface_Overloads;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$interfaces corba}',
|
||||
'type',
|
||||
' integer = longint;',
|
||||
' IUnknown = interface',
|
||||
' procedure DoIt(i: integer);',
|
||||
' procedure DoIt(s: string);',
|
||||
' end;',
|
||||
' IBird = interface(IUnknown)',
|
||||
' procedure DoIt(b: boolean); overload;',
|
||||
' end;',
|
||||
' TObject = class',
|
||||
' end;',
|
||||
' TBird = class(TObject,IBird)',
|
||||
' procedure DoIt(o: TObject);',
|
||||
' procedure DoIt(s: string);',
|
||||
' procedure DoIt(i: integer);',
|
||||
' procedure DoIt(b: boolean);',
|
||||
' end;',
|
||||
'procedure TBird.DoIt(o: TObject); begin end;',
|
||||
'procedure TBird.DoIt(s: string); begin end;',
|
||||
'procedure TBird.DoIt(i: integer); begin end;',
|
||||
'procedure TBird.DoIt(b: boolean); begin end;',
|
||||
'var',
|
||||
' BirdIntf: IBird;',
|
||||
'begin',
|
||||
' BirdIntf.DoIt(3);',
|
||||
' BirdIntf.DoIt(''abc'');',
|
||||
' BirdIntf.DoIt(true);',
|
||||
'']);
|
||||
ConvertProgram;
|
||||
CheckSource('TestClassInterface_Overloads',
|
||||
LinesToStr([ // statements
|
||||
'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E71-32CA-B8EF-650000000000}", ["DoIt", "DoIt$1"], null);',
|
||||
'rtl.createInterface($mod, "IBird", "{D2E3FF4A-AF76-3468-AB38-EB26B77CE676}", ["DoIt$2"], $mod.IUnknown);',
|
||||
'rtl.createClass($mod, "TObject", null, function () {',
|
||||
' this.$init = function () {',
|
||||
' };',
|
||||
' this.$final = function () {',
|
||||
' };',
|
||||
'});',
|
||||
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
||||
' this.DoIt = function (o) {',
|
||||
' };',
|
||||
' this.DoIt$1 = function (s) {',
|
||||
' };',
|
||||
' this.DoIt$2 = function (i) {',
|
||||
' };',
|
||||
' this.DoIt$3 = function (b) {',
|
||||
' };',
|
||||
' this.$intfmaps = {};',
|
||||
' rtl.addIntf(this, $mod.IBird, {',
|
||||
' DoIt$2: "DoIt$3",',
|
||||
' DoIt: "DoIt$2"',
|
||||
' });',
|
||||
'});',
|
||||
'this.BirdIntf = null;',
|
||||
'']),
|
||||
LinesToStr([ // $mod.$main
|
||||
'$mod.BirdIntf.DoIt(3);',
|
||||
'$mod.BirdIntf.DoIt$1("abc");',
|
||||
'$mod.BirdIntf.DoIt$2(true);',
|
||||
'']));
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestClassInterface_AncestorImpl;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$interfaces corba}',
|
||||
'type',
|
||||
' integer = longint;',
|
||||
' IUnknown = interface',
|
||||
' procedure DoIt(i: integer);',
|
||||
' end;',
|
||||
' IBird = interface',
|
||||
' procedure Fly(i: integer);',
|
||||
' end;',
|
||||
' TObject = class(IUnknown)',
|
||||
' procedure DoIt(i: integer);',
|
||||
' end;',
|
||||
' TBird = class(IBird)',
|
||||
' procedure Fly(i: integer);',
|
||||
' end;',
|
||||
'procedure TObject.DoIt(i: integer); begin end;',
|
||||
'procedure TBird.Fly(i: integer); begin end;',
|
||||
'begin',
|
||||
'']);
|
||||
ConvertProgram;
|
||||
CheckSource('TestClassInterface_AncestorIntf',
|
||||
LinesToStr([ // statements
|
||||
'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E71-32CA-8000-000000000000}", ["DoIt"], null);',
|
||||
'rtl.createInterface($mod, "IBird", "{585952B8-2CC8-3000-8000-000000000000}", ["Fly"], null);',
|
||||
'rtl.createClass($mod, "TObject", null, function () {',
|
||||
' this.$init = function () {',
|
||||
' };',
|
||||
' this.$final = function () {',
|
||||
' };',
|
||||
' this.DoIt = function (i) {',
|
||||
' };',
|
||||
' this.$intfmaps = {};',
|
||||
' rtl.addIntf(this, $mod.IUnknown);',
|
||||
'});',
|
||||
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
||||
' this.Fly = function (i) {',
|
||||
' };',
|
||||
' this.$intfmaps = {};',
|
||||
' rtl.addIntf(this, $mod.IBird);',
|
||||
' rtl.addIntf(this, $mod.IUnknown);',
|
||||
'});',
|
||||
'']),
|
||||
LinesToStr([ // $mod.$main
|
||||
'']));
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestClassInterface_ImplReintroduce;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$interfaces corba}',
|
||||
'type',
|
||||
' integer = longint;',
|
||||
' IBird = interface',
|
||||
' procedure DoIt(i: integer);',
|
||||
' end;',
|
||||
' TObject = class',
|
||||
' procedure DoIt(i: integer);',
|
||||
' end;',
|
||||
' TBird = class(IBird)',
|
||||
' procedure DoIt(i: integer); virtual; reintroduce;',
|
||||
' end;',
|
||||
'procedure TObject.DoIt(i: integer); begin end;',
|
||||
'procedure TBird.DoIt(i: integer); begin end;',
|
||||
'begin',
|
||||
'']);
|
||||
ConvertProgram;
|
||||
CheckSource('TestClassInterface_ImplReintroduce',
|
||||
LinesToStr([ // statements
|
||||
'rtl.createInterface($mod, "IBird", "{585952B8-EF65-3000-8000-000000000000}", ["DoIt"], null);',
|
||||
'rtl.createClass($mod, "TObject", null, function () {',
|
||||
' this.$init = function () {',
|
||||
' };',
|
||||
' this.$final = function () {',
|
||||
' };',
|
||||
' this.DoIt = function (i) {',
|
||||
' };',
|
||||
'});',
|
||||
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
||||
' this.DoIt$1 = function (i) {',
|
||||
' };',
|
||||
' this.$intfmaps = {};',
|
||||
' rtl.addIntf(this, $mod.IBird, {',
|
||||
' DoIt: "DoIt$1"',
|
||||
' });',
|
||||
'});',
|
||||
'']),
|
||||
LinesToStr([ // $mod.$main
|
||||
'']));
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestClassInterface_MethodResolution;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$interfaces corba}',
|
||||
'type',
|
||||
' IUnknown = interface',
|
||||
' procedure Walk(i: longint);',
|
||||
' end;',
|
||||
' IBird = interface(IUnknown)',
|
||||
' procedure Walk(b: boolean); overload;',
|
||||
' procedure Fly(s: string);',
|
||||
' end;',
|
||||
' TObject = class',
|
||||
' end;',
|
||||
' TBird = class(TObject,IBird)',
|
||||
' procedure IBird.Fly = Move;',
|
||||
' procedure IBird.Walk = Hop;',
|
||||
' procedure Hop(i: longint);',
|
||||
' procedure Move(s: string);',
|
||||
' procedure Hop(b: boolean);',
|
||||
' end;',
|
||||
'procedure TBird.Move(s: string); begin end;',
|
||||
'procedure TBird.Hop(i: longint); begin end;',
|
||||
'procedure TBird.Hop(b: boolean); begin end;',
|
||||
'var',
|
||||
' BirdIntf: IBird;',
|
||||
'begin',
|
||||
' BirdIntf.Walk(3);',
|
||||
' BirdIntf.Walk(true);',
|
||||
' BirdIntf.Fly(''abc'');',
|
||||
'']);
|
||||
ConvertProgram;
|
||||
CheckSource('TestClassInterface_MethodResolution',
|
||||
LinesToStr([ // statements
|
||||
'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E75-38F5-8000-000000000000}", ["Walk"], null);',
|
||||
'rtl.createInterface($mod, "IBird", "{F8E3FF4A-AF76-3468-BB38-1CCFAB120092}", ["Walk$1", "Fly"], $mod.IUnknown);',
|
||||
'rtl.createClass($mod, "TObject", null, function () {',
|
||||
' this.$init = function () {',
|
||||
' };',
|
||||
' this.$final = function () {',
|
||||
' };',
|
||||
'});',
|
||||
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
||||
' this.Hop = function (i) {',
|
||||
' };',
|
||||
' this.Move = function (s) {',
|
||||
' };',
|
||||
' this.Hop$1 = function (b) {',
|
||||
' };',
|
||||
' this.$intfmaps = {};',
|
||||
' rtl.addIntf(this, $mod.IBird, {',
|
||||
' Walk$1: "Hop$1",',
|
||||
' Fly: "Move",',
|
||||
' Walk: "Hop"',
|
||||
' });',
|
||||
'});',
|
||||
'this.BirdIntf = null;',
|
||||
'']),
|
||||
LinesToStr([ // $mod.$main
|
||||
'$mod.BirdIntf.Walk(3);',
|
||||
'$mod.BirdIntf.Walk$1(true);',
|
||||
'$mod.BirdIntf.Fly("abc");',
|
||||
'']));
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestClassInterface_Delegation;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$interfaces corba}',
|
||||
'type',
|
||||
' IUnknown = interface',
|
||||
' end;',
|
||||
' IBird = interface(IUnknown)',
|
||||
' procedure Fly(s: string);',
|
||||
' end;',
|
||||
' IEagle = interface(IBird)',
|
||||
' end;',
|
||||
' IDove = interface(IBird)',
|
||||
' end;',
|
||||
' ISwallow = interface(IBird)',
|
||||
' end;',
|
||||
' TObject = class',
|
||||
' end;',
|
||||
' TBird = class(TObject,IBird,IEagle,IDove,ISwallow)',
|
||||
' procedure Fly(s: string); virtual; abstract;',
|
||||
' end;',
|
||||
' TBat = class(IBird,IEagle,IDove,ISwallow)',
|
||||
' FBirdIntf: IBird;',
|
||||
' property BirdIntf: IBird read FBirdIntf implements IBird;',
|
||||
' function GetEagleIntf: IEagle; virtual; abstract;',
|
||||
' property EagleIntf: IEagle read GetEagleIntf implements IEagle;',
|
||||
' FDoveObj: TBird;',
|
||||
' property DoveObj: TBird read FDoveObj implements IDove;',
|
||||
' function GetSwallowObj: TBird; virtual; abstract;',
|
||||
' property SwallowObj: TBird read GetSwallowObj implements ISwallow;',
|
||||
' end;',
|
||||
'begin',
|
||||
'']);
|
||||
ConvertProgram;
|
||||
CheckSource('TestClassInterface_Delegation',
|
||||
LinesToStr([ // statements
|
||||
'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E00-3000-8000-000000000000}", [], null);',
|
||||
'rtl.createInterface($mod, "IBird", "{48E3FF4A-AF76-3465-A738-D745ABE63074}", ["Fly"], $mod.IUnknown);',
|
||||
'rtl.createInterface($mod, "IEagle", "{56CEF525-B037-3078-82F5-4C3CF0629879}", [], $mod.IBird);',
|
||||
'rtl.createInterface($mod, "IDove", "{56CEF525-B037-3078-8169-F7ECF0629879}", [], $mod.IBird);',
|
||||
'rtl.createInterface($mod, "ISwallow", "{56CEF525-B037-3078-90A3-CCE44C629879}", [], $mod.IBird);',
|
||||
'rtl.createClass($mod, "TObject", null, function () {',
|
||||
' this.$init = function () {',
|
||||
' };',
|
||||
' this.$final = function () {',
|
||||
' };',
|
||||
'});',
|
||||
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
||||
' this.$intfmaps = {};',
|
||||
' rtl.addIntf(this, $mod.IBird);',
|
||||
' rtl.addIntf(this, $mod.IEagle);',
|
||||
' rtl.addIntf(this, $mod.IDove);',
|
||||
' rtl.addIntf(this, $mod.ISwallow);',
|
||||
'});',
|
||||
'rtl.createClass($mod, "TBat", $mod.TObject, function () {',
|
||||
' this.$init = function () {',
|
||||
' $mod.TObject.$init.call(this);',
|
||||
' this.FBirdIntf = null;',
|
||||
' this.FDoveObj = null;',
|
||||
' };',
|
||||
' this.$final = function () {',
|
||||
' this.FBirdIntf = undefined;',
|
||||
' this.FDoveObj = undefined;',
|
||||
' $mod.TObject.$final.call(this);',
|
||||
' };',
|
||||
' this.$intfmaps = {',
|
||||
' "{48E3FF4A-AF76-3465-A738-D745ABE63074}": function () {',
|
||||
' return this.FBirdIntf;',
|
||||
' },',
|
||||
' "{56CEF525-B037-3078-82F5-4C3CF0629879}": function () {',
|
||||
' return this.GetEagleIntf();',
|
||||
' },',
|
||||
' "{56CEF525-B037-3078-8169-F7ECF0629879}": function () {',
|
||||
' return rtl.getIntfT(this.FDoveObj, $mod.TBird);',
|
||||
' },',
|
||||
' "{56CEF525-B037-3078-90A3-CCE44C629879}": function () {',
|
||||
' return rtl.getIntfT(this.GetSwallowObj(), $mod.TBird);',
|
||||
' }',
|
||||
' };',
|
||||
'});',
|
||||
'']),
|
||||
LinesToStr([ // $mod.$main
|
||||
'']));
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestClassInterface_DelegationStatic;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$interfaces corba}',
|
||||
'type',
|
||||
' IUnknown = interface',
|
||||
' end;',
|
||||
' IBird = interface(IUnknown)',
|
||||
' procedure Fly(s: string);',
|
||||
' end;',
|
||||
' IEagle = interface(IBird)',
|
||||
' end;',
|
||||
' IDove = interface(IBird)',
|
||||
' end;',
|
||||
' ISwallow = interface(IBird)',
|
||||
' end;',
|
||||
' TObject = class',
|
||||
' end;',
|
||||
' TBird = class(TObject,IBird,IEagle,IDove,ISwallow)',
|
||||
' procedure Fly(s: string); virtual; abstract;',
|
||||
' end;',
|
||||
' TBat = class(IBird,IEagle,IDove,ISwallow)',
|
||||
' private',
|
||||
' class var FBirdIntf: IBird;',
|
||||
' class var FDoveObj: TBird;',
|
||||
' class function GetEagleIntf: IEagle; virtual; abstract;',
|
||||
' class function GetSwallowObj: TBird; virtual; abstract;',
|
||||
' protected',
|
||||
' class property BirdIntf: IBird read FBirdIntf implements IBird;',
|
||||
' class property EagleIntf: IEagle read GetEagleIntf implements IEagle;',
|
||||
' class property DoveObj: TBird read FDoveObj implements IDove;',
|
||||
' class property SwallowObj: TBird read GetSwallowObj implements ISwallow;',
|
||||
' end;',
|
||||
'begin',
|
||||
'']);
|
||||
ConvertProgram;
|
||||
CheckSource('TestClassInterface_DelegationStatic',
|
||||
LinesToStr([ // statements
|
||||
'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E00-3000-8000-000000000000}", [], null);',
|
||||
'rtl.createInterface($mod, "IBird", "{48E3FF4A-AF76-3465-A738-D745ABE63074}", ["Fly"], $mod.IUnknown);',
|
||||
'rtl.createInterface($mod, "IEagle", "{56CEF525-B037-3078-82F5-4C3CF0629879}", [], $mod.IBird);',
|
||||
'rtl.createInterface($mod, "IDove", "{56CEF525-B037-3078-8169-F7ECF0629879}", [], $mod.IBird);',
|
||||
'rtl.createInterface($mod, "ISwallow", "{56CEF525-B037-3078-90A3-CCE44C629879}", [], $mod.IBird);',
|
||||
'rtl.createClass($mod, "TObject", null, function () {',
|
||||
' this.$init = function () {',
|
||||
' };',
|
||||
' this.$final = function () {',
|
||||
' };',
|
||||
'});',
|
||||
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
||||
' this.$intfmaps = {};',
|
||||
' rtl.addIntf(this, $mod.IBird);',
|
||||
' rtl.addIntf(this, $mod.IEagle);',
|
||||
' rtl.addIntf(this, $mod.IDove);',
|
||||
' rtl.addIntf(this, $mod.ISwallow);',
|
||||
'});',
|
||||
'rtl.createClass($mod, "TBat", $mod.TObject, function () {',
|
||||
' this.FBirdIntf = null;',
|
||||
' this.FDoveObj = null;',
|
||||
' this.$intfmaps = {',
|
||||
' "{48E3FF4A-AF76-3465-A738-D745ABE63074}": function () {',
|
||||
' return this.FBirdIntf;',
|
||||
' },',
|
||||
' "{56CEF525-B037-3078-82F5-4C3CF0629879}": function () {',
|
||||
' return this.$class.GetEagleIntf();',
|
||||
' },',
|
||||
' "{56CEF525-B037-3078-8169-F7ECF0629879}": function () {',
|
||||
' return rtl.getIntfT(this.FDoveObj, $mod.TBird);',
|
||||
' },',
|
||||
' "{56CEF525-B037-3078-90A3-CCE44C629879}": function () {',
|
||||
' return rtl.getIntfT(this.$class.GetSwallowObj(), $mod.TBird);',
|
||||
' }',
|
||||
' };',
|
||||
'});',
|
||||
'']),
|
||||
LinesToStr([ // $mod.$main
|
||||
'']));
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestClassInterface_Operators;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$interfaces corba}',
|
||||
'type',
|
||||
' IUnknown = interface',
|
||||
' end;',
|
||||
' IBird = interface(IUnknown)',
|
||||
' function GetItems(Index: longint): longint;',
|
||||
' procedure SetItems(Index: longint; Value: longint);',
|
||||
' property Items[Index: longint]: longint read GetItems write SetItems; default;',
|
||||
' end;',
|
||||
' TObject = class',
|
||||
' end;',
|
||||
' TBird = class(TObject,IBird)',
|
||||
' function GetItems(Index: longint): longint; virtual; abstract;',
|
||||
' procedure SetItems(Index: longint; Value: longint); virtual; abstract;',
|
||||
' end;',
|
||||
'var',
|
||||
' IntfVar: IBird = nil;',
|
||||
' IntfVar2: IBird;',
|
||||
' ObjVar: TBird;',
|
||||
' v: JSValue;',
|
||||
'begin',
|
||||
' IntfVar:=nil;',
|
||||
' IntfVar[3]:=IntfVar[4];',
|
||||
' if Assigned(IntfVar) then ;',
|
||||
' IntfVar:=IntfVar2;',
|
||||
' IntfVar:=ObjVar;',
|
||||
' if IntfVar=IntfVar2 then ;',
|
||||
' if IntfVar<>IntfVar2 then ;',
|
||||
' if IntfVar is IBird then ;',
|
||||
' if IntfVar is TBird then ;',
|
||||
' if ObjVar is IBird then ;',
|
||||
' IntfVar:=IntfVar2 as IBird;',
|
||||
' ObjVar:=IntfVar2 as TBird;',
|
||||
' IntfVar:=ObjVar as IBird;',
|
||||
' IntfVar:=IBird(IntfVar2);',
|
||||
' ObjVar:=TBird(IntfVar);',
|
||||
' IntfVar:=IBird(ObjVar);',
|
||||
' v:=IntfVar;',
|
||||
' IntfVar:=IBird(v);',
|
||||
' if v is IBird then ;',
|
||||
' v:=JSValue(IntfVar);',
|
||||
'']);
|
||||
ConvertProgram;
|
||||
CheckSource('TestClassInterface_Operators',
|
||||
LinesToStr([ // statements
|
||||
'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E00-3000-8000-000000000000}", [], null);',
|
||||
'rtl.createInterface($mod, "IBird", "{8E3C13AF-8080-3465-A738-D7460F8FE995}", ["GetItems", "SetItems"], $mod.IUnknown);',
|
||||
'rtl.createClass($mod, "TObject", null, function () {',
|
||||
' this.$init = function () {',
|
||||
' };',
|
||||
' this.$final = function () {',
|
||||
' };',
|
||||
'});',
|
||||
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
||||
' this.$intfmaps = {};',
|
||||
' rtl.addIntf(this, $mod.IBird);',
|
||||
'});',
|
||||
'this.IntfVar = null;',
|
||||
'this.IntfVar2 = null;',
|
||||
'this.ObjVar = null;',
|
||||
'this.v = undefined;',
|
||||
'']),
|
||||
LinesToStr([ // $mod.$main
|
||||
'$mod.IntfVar = null;',
|
||||
'$mod.IntfVar.SetItems(3, $mod.IntfVar.GetItems(4));',
|
||||
'if ($mod.IntfVar != null) ;',
|
||||
'$mod.IntfVar = $mod.IntfVar2;',
|
||||
'$mod.IntfVar = rtl.getIntfT($mod.ObjVar,$mod.IBird);',
|
||||
'if ($mod.IntfVar === $mod.IntfVar2) ;',
|
||||
'if ($mod.IntfVar !== $mod.IntfVar2) ;',
|
||||
'if ($mod.IBird.isPrototypeOf($mod.IntfVar)) ;',
|
||||
'if (rtl.intfIsClass($mod.IntfVar, $mod.TBird)) ;',
|
||||
'if (rtl.getIntfT($mod.ObjVar, $mod.IBird) !== null) ;',
|
||||
'$mod.IntfVar = rtl.as($mod.IntfVar2, $mod.IBird);',
|
||||
'$mod.ObjVar = rtl.intfAsClass($mod.IntfVar2, $mod.TBird);',
|
||||
'$mod.IntfVar = rtl.getIntfT($mod.ObjVar, $mod.IBird);',
|
||||
'$mod.IntfVar = $mod.IntfVar2;',
|
||||
'$mod.ObjVar = rtl.intfToClass($mod.IntfVar, $mod.TBird);',
|
||||
'$mod.IntfVar = rtl.getIntfT($mod.ObjVar, $mod.IBird);',
|
||||
'$mod.v = $mod.IntfVar;',
|
||||
'$mod.IntfVar = rtl.getObject($mod.v);',
|
||||
'if (rtl.isExt($mod.v, $mod.IBird, 1)) ;',
|
||||
'$mod.v = rtl.getObject($mod.IntfVar);',
|
||||
'']));
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestClassInterface_Args;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$interfaces corba}',
|
||||
'type',
|
||||
' IUnknown = interface',
|
||||
' end;',
|
||||
' IBird = interface(IUnknown)',
|
||||
' end;',
|
||||
' TObject = class',
|
||||
' end;',
|
||||
' TBird = class(TObject,IBird)',
|
||||
' end;',
|
||||
'procedure DoIt(var u; i: IBird; const j: IBird);',
|
||||
'begin',
|
||||
' DoIt(i,i,i);',
|
||||
'end;',
|
||||
'procedure Change(var i: IBird; out j: IBird);',
|
||||
'begin',
|
||||
' DoIt(i,i,i);',
|
||||
' Change(i,i);',
|
||||
'end;',
|
||||
'var',
|
||||
' i: IBird;',
|
||||
' o: TBird;',
|
||||
'begin',
|
||||
' DoIt(i,i,i);',
|
||||
' Change(i,i);',
|
||||
' DoIt(o,o,o);',
|
||||
'']);
|
||||
ConvertProgram;
|
||||
CheckSource('TestClassInterface_Args',
|
||||
LinesToStr([ // statements
|
||||
'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E00-3000-8000-000000000000}", [], null);',
|
||||
'rtl.createInterface($mod, "IBird", "{48E3FF4A-AF76-3465-A738-D462ECC63074}", [], $mod.IUnknown);',
|
||||
'rtl.createClass($mod, "TObject", null, function () {',
|
||||
' this.$init = function () {',
|
||||
' };',
|
||||
' this.$final = function () {',
|
||||
' };',
|
||||
'});',
|
||||
'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
|
||||
' this.$intfmaps = {};',
|
||||
' rtl.addIntf(this, $mod.IBird);',
|
||||
'});',
|
||||
'this.DoIt = function (u, i, j) {',
|
||||
' $mod.DoIt({',
|
||||
' get: function () {',
|
||||
' return i;',
|
||||
' },',
|
||||
' set: function (v) {',
|
||||
' i = v;',
|
||||
' }',
|
||||
' }, i, i);',
|
||||
'};',
|
||||
'this.Change = function (i, j) {',
|
||||
' $mod.DoIt(i, i.get(), i.get());',
|
||||
' $mod.Change(i, i);',
|
||||
'};',
|
||||
'this.i = null;',
|
||||
'this.o = null;',
|
||||
'']),
|
||||
LinesToStr([ // $mod.$main
|
||||
'$mod.DoIt({',
|
||||
' p: $mod,',
|
||||
' get: function () {',
|
||||
' return this.p.i;',
|
||||
' },',
|
||||
' set: function (v) {',
|
||||
' this.p.i = v;',
|
||||
' }',
|
||||
'}, $mod.i, $mod.i);',
|
||||
'$mod.Change({',
|
||||
' p: $mod,',
|
||||
' get: function () {',
|
||||
' return this.p.i;',
|
||||
' },',
|
||||
' set: function (v) {',
|
||||
' this.p.i = v;',
|
||||
' }',
|
||||
'}, {',
|
||||
' p: $mod,',
|
||||
' get: function () {',
|
||||
' return this.p.i;',
|
||||
' },',
|
||||
' set: function (v) {',
|
||||
' this.p.i = v;',
|
||||
' }',
|
||||
'});',
|
||||
'$mod.DoIt({',
|
||||
' p: $mod,',
|
||||
' get: function () {',
|
||||
' return this.p.o;',
|
||||
' },',
|
||||
' set: function (v) {',
|
||||
' this.p.o = v;',
|
||||
' }',
|
||||
'}, rtl.getIntfT($mod.o, $mod.IBird), rtl.getIntfT($mod.o, $mod.IBird));',
|
||||
'']));
|
||||
end;
|
||||
|
||||
procedure TTestModule.TestClassInterface_ForInCorbaIntf;
|
||||
begin
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$interfaces corba}',
|
||||
'type',
|
||||
' IUnknown = interface end;',
|
||||
' TObject = class',
|
||||
' Id: longint;',
|
||||
' end;',
|
||||
' IEnumerator = interface(IUnknown)',
|
||||
' function GetCurrent: TObject;',
|
||||
' function MoveNext: Boolean;',
|
||||
' property Current: TObject read GetCurrent;',
|
||||
' end;',
|
||||
' IEnumerable = interface(IUnknown)',
|
||||
' function GetEnumerator: IEnumerator;',
|
||||
' end;',
|
||||
'var',
|
||||
' o: TObject;',
|
||||
' i: IEnumerable;',
|
||||
'begin',
|
||||
' for o in i do o.Id:=3;',
|
||||
'']);
|
||||
ConvertProgram;
|
||||
CheckSource('TestClassInterface_ForInCorbaIntf',
|
||||
LinesToStr([ // statements
|
||||
'rtl.createInterface($mod, "IUnknown", "{5D22E7CA-4E00-3000-8000-000000000000}", [], null);',
|
||||
'rtl.createClass($mod, "TObject", null, function () {',
|
||||
' this.$init = function () {',
|
||||
' this.Id = 0;',
|
||||
' };',
|
||||
' this.$final = function () {',
|
||||
' };',
|
||||
'});',
|
||||
'rtl.createInterface($mod, "IEnumerator", "{D2FE11F3-D2CC-36BB-A5B2-66EB7FB5CB08}", ["GetCurrent", "MoveNext"], $mod.IUnknown);',
|
||||
'rtl.createInterface($mod, "IEnumerable", "{D20534CB-D9C0-3EA5-AA60-ACEB7D726308}", ["GetEnumerator"], $mod.IUnknown);',
|
||||
'this.o = null;',
|
||||
'this.i = null;',
|
||||
'']),
|
||||
LinesToStr([ // $mod.$main
|
||||
'var $in1 = $mod.i.GetEnumerator();',
|
||||
'while ($in1.MoveNext()) {',
|
||||
' $mod.o = $in1.GetCurrent();',
|
||||
' $mod.o.Id = 3;',
|
||||
'};',
|
||||
'']));
|
||||
end;
|
||||
|
||||
{$ELSE}
|
||||
procedure TTestModule.TestClassInterface_Ignore;
|
||||
begin
|
||||
StartProgram(false);
|
||||
@ -12325,6 +13103,7 @@ begin
|
||||
'$mod.i.RefCount = 3;',
|
||||
'']));
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
procedure TTestModule.TestProcType;
|
||||
begin
|
||||
@ -16631,6 +17410,66 @@ begin
|
||||
'']));
|
||||
end;
|
||||
|
||||
{$IFDEF EnableInterfaces}
|
||||
procedure TTestModule.TestRTTI_Interface;
|
||||
begin
|
||||
Converter.Options:=Converter.Options-[coNoTypeInfo];
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$interfaces corba}',
|
||||
'{$modeswitch externalclass}',
|
||||
'type',
|
||||
' IUnknown = interface',
|
||||
' end;',
|
||||
' IBird = interface',
|
||||
' function GetItem: longint;',
|
||||
' procedure SetItem(Value: longint);',
|
||||
' property Item: longint read GetItem write SetItem;',
|
||||
' end;',
|
||||
' TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
|
||||
' TTypeInfoInterface = class external name ''rtl.tTypeInfoInterface''(TTypeInfo) end;',
|
||||
'var',
|
||||
' i: IBird;',
|
||||
' t: TTypeInfoInterface;',
|
||||
'begin',
|
||||
' t:=TypeInfo(IBird);',
|
||||
' t:=TypeInfo(i);',
|
||||
'']);
|
||||
ConvertProgram;
|
||||
CheckSource('TestRTTI_Interface',
|
||||
LinesToStr([ // statements
|
||||
'rtl.createInterface(',
|
||||
' $mod,',
|
||||
' "IUnknown",',
|
||||
' "{5D22E7CA-4E00-3000-8000-000000000000}",',
|
||||
' [],',
|
||||
' null,',
|
||||
' function () {',
|
||||
' }',
|
||||
');',
|
||||
'rtl.createInterface(',
|
||||
' $mod,',
|
||||
' "IBird",',
|
||||
' "{585952B8-45B2-3E86-BAC5-B22E86800000}",',
|
||||
' ["GetItem", "SetItem"],',
|
||||
' null,',
|
||||
' function () {',
|
||||
' var $r = this.$rtti;',
|
||||
' $r.addMethod("GetItem", 1, null, rtl.longint);',
|
||||
' $r.addMethod("SetItem", 0, [["Value", rtl.longint]]);',
|
||||
' $r.addProperty("Item", 3, rtl.longint, "GetItem", "SetItem");',
|
||||
' }',
|
||||
');',
|
||||
'this.i = null;',
|
||||
'this.t = null;',
|
||||
'']),
|
||||
LinesToStr([ // $mod.$main
|
||||
'$mod.t = $mod.$rtti["IBird"];',
|
||||
'$mod.t = $mod.i.$rtti;',
|
||||
'']));
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
procedure TTestModule.TestResourcestringProgram;
|
||||
begin
|
||||
StartProgram(false);
|
||||
|
||||
@ -56,7 +56,11 @@ type
|
||||
procedure TestPCU_UnitCycle;
|
||||
procedure TestPCU_ClassForward;
|
||||
procedure TestPCU_ClassConstructor;
|
||||
{$IFDEF EnableInterfaces}
|
||||
procedure TestPCU_ClassInterface;
|
||||
{$ELSE}
|
||||
procedure TestPCU_IgnoreInterface;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function LinesToList(const Lines: array of string): TStringList;
|
||||
@ -316,6 +320,75 @@ begin
|
||||
CheckPrecompile('test1.pas','src');
|
||||
end;
|
||||
|
||||
{$IFDEF EnableInterfaces}
|
||||
procedure TTestCLI_Precompile.TestPCU_ClassInterface;
|
||||
begin
|
||||
AddUnit('src/system.pp',[
|
||||
'{$interfaces corba}',
|
||||
'type',
|
||||
' integer = longint;',
|
||||
' IUnknown = interface',
|
||||
' end;',
|
||||
'procedure Writeln; varargs;'],
|
||||
['procedure Writeln; begin end;']);
|
||||
AddUnit('src/unit1.pp',[
|
||||
'type',
|
||||
' IIntf = interface',
|
||||
' function GetItems(Index: longint): longint;',
|
||||
' procedure SetItems(Index: longint; Value: longint);',
|
||||
' property Items[Index: longint]: longint read GetItems write SetItems; default;',
|
||||
' end;',
|
||||
''],[
|
||||
'']);
|
||||
AddUnit('src/unit2.pp',[
|
||||
'uses unit1;',
|
||||
'type',
|
||||
' IAlias = IIntf;',
|
||||
' TObject = class end;',
|
||||
' TBird = class(IIntf)',
|
||||
' strict private',
|
||||
' function IIntf.GetItems = FetchItems;',
|
||||
' function FetchItems(Index: longint): longint; virtual; abstract;',
|
||||
' procedure SetItems(Index: longint; Value: longint); virtual; abstract;',
|
||||
' end;',
|
||||
''],[
|
||||
'']);
|
||||
AddUnit('src/unit3.pp',[
|
||||
'uses unit2;',
|
||||
'type',
|
||||
' TEagle = class(TBird)',
|
||||
' function FetchItems(Index: longint): longint; override;',
|
||||
' procedure SetItems(Index: longint; Value: longint); override;',
|
||||
' end;',
|
||||
' TFlying = class(IAlias)',
|
||||
' strict private',
|
||||
' FEagle: TEagle;',
|
||||
' property Eagle: TEagle read FEagle implements IAlias;',
|
||||
' public',
|
||||
' constructor Create;',
|
||||
' end;',
|
||||
''],[
|
||||
'function TEagle.FetchItems(Index: longint): longint; begin end;',
|
||||
'procedure TEagle.SetItems(Index: longint; Value: longint); begin end;',
|
||||
'constructor TFlying.Create;',
|
||||
'begin',
|
||||
' FEagle:=nil;',
|
||||
'end;',
|
||||
'']);
|
||||
AddFile('test1.pas',[
|
||||
'uses unit2, unit3;',
|
||||
'type IAlias2 = IAlias;',
|
||||
'var',
|
||||
' f: TFlying;',
|
||||
' i: IAlias2;',
|
||||
'begin',
|
||||
' f:=TFlying.Create;',
|
||||
' i:=f;',
|
||||
' i[2]:=i[3];',
|
||||
'end.']);
|
||||
CheckPrecompile('test1.pas','src');
|
||||
end;
|
||||
{$ELSE}
|
||||
procedure TTestCLI_Precompile.TestPCU_IgnoreInterface;
|
||||
begin
|
||||
AddUnit('src/system.pp',[
|
||||
@ -336,7 +409,7 @@ begin
|
||||
'type',
|
||||
' IAlias = IIntf;',
|
||||
' TObject = class end;',
|
||||
' TBird = class(IIntf) end;',
|
||||
' TBird = class(TObject,IIntf) end;',
|
||||
''],[
|
||||
'']);
|
||||
AddFile('test1.pas',[
|
||||
@ -348,6 +421,7 @@ begin
|
||||
'end.']);
|
||||
CheckPrecompile('test1.pas','src');
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
Initialization
|
||||
RegisterTests([TTestCLI_Precompile]);
|
||||
|
||||
Loading…
Reference in New Issue
Block a user