pastojs: corba interfaces

git-svn-id: trunk@38651 -

packages/pastojs/src/pas2jsfiler.pp

@@ -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}

packages/pastojs/tests/tcfiler.pas

@@ -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

packages/pastojs/tests/tcmodules.pas

@@ -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);

packages/pastojs/tests/tcprecompile.pas

@@ -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]);