pastojs: implemented string:=interface

git-svn-id: trunk@38727 -

packages/pastojs/src/fppas2js.pp

@@ -303,6 +303,10 @@ Works:
   - COM: for interface in ... do
 
 ToDos:
+- interfaces:
+  - GUID
+  - for i in jsvalue do
+  - for i in tjsobject do
 - 'new', 'Function' -> class var use .prototype
 - btArrayLit
   a: array of jsvalue;
@@ -533,6 +537,7 @@ type
     pbifnUnitInit,
     pbivnExceptObject,
     pbivnIntfExprRefs,
+    pbivnIntfGUID,
     pbivnIntfKind,
     pbivnIntfMaps,
     pbivnImplementation,
@@ -665,6 +670,7 @@ const
     '$init',
     '$e',
     '$ir',
+    '$guid',
     '$kind',
     '$intfmaps',
     '$impl',
@@ -3014,8 +3020,10 @@ var
   LeftBaseType: TPas2jsBaseType;
   LArray: TPasArrayType;
   ElTypeResolved: TPasResolverResult;
+  LTypeEl, RTypeEl: TPasType;
 begin
   Result:=cIncompatible;
+  //writeln('TPas2JSResolver.CheckAssignCompatibilityCustom ',GetResolverResultDbg(LHS));
   if LHS.BaseType=btCustom then
     begin
     if not (LHS.TypeEl is TPasUnresolvedSymbolRef) then
@@ -3056,20 +3064,36 @@ begin
         end;
       end;
     end
-  else if (LHS.BaseType=btContext) and (LHS.TypeEl.ClassType=TPasArrayType)
-      and (rrfReadable in RHS.Flags) then
+  else if (LHS.BaseType=btContext) then
     begin
-    LArray:=TPasArrayType(LHS.TypeEl);
-    if length(LArray.Ranges)>0 then
-      exit;
-    if (RHS.BaseType<>btContext) or (RHS.TypeEl.ClassType<>TPasArrayType) then
-      exit;
-    ComputeElement(LArray.ElType,ElTypeResolved,[rcType]);
-    if IsJSBaseType(ElTypeResolved,pbtJSValue) then
+    LTypeEl:=ResolveAliasType(LHS.TypeEl);
+    RTypeEl:=ResolveAliasType(RHS.TypeEl);
+    if (LTypeEl.ClassType=TPasArrayType)
+        and (rrfReadable in RHS.Flags) then
+      begin
+      LArray:=TPasArrayType(LTypeEl);
+      if length(LArray.Ranges)>0 then
+        exit;
+      if (RHS.BaseType<>btContext) or (RTypeEl.ClassType<>TPasArrayType) then
+        exit;
+      ComputeElement(LArray.ElType,ElTypeResolved,[rcType]);
+      if IsJSBaseType(ElTypeResolved,pbtJSValue) then
+        begin
+        // array of jsvalue := array
+        Handled:=true;
+        Result:=cJSValueConversion;
+        end;
+      end;
+    end
+  else if LHS.BaseType=btString then
+    begin
+    RTypeEl:=ResolveAliasType(RHS.TypeEl);
+    if (RTypeEl is TPasClassType)
+        and (TPasClassType(RTypeEl).ObjKind=okInterface) then
       begin
-      // array of jsvalue := array
+      // string:=interface
       Handled:=true;
-      Result:=cJSValueConversion;
+      Result:=cLossyConversion;
       end;
     end;
 
@@ -12657,7 +12681,16 @@ begin
       else if RightTypeEl.ClassType=TPasClassType then
         begin
         LeftTypeEl:=aResolver.ResolveAliasType(AssignContext.LeftResolved.TypeEl);
-        if LeftTypeEl is TPasClassType then
+        if AssignContext.LeftResolved.BaseType=btString then
+          begin
+          if TPasClassType(RightTypeEl).ObjKind=okInterface then
+            begin
+            // string:=interface  ->  string = interface.$guid
+            AssignContext.RightSide:=CreateDotExpression(El,AssignContext.RightSide,
+              CreatePrimitiveDotExpr(FBuiltInNames[pbivnIntfGUID],El));
+            end;
+          end
+        else if LeftTypeEl is TPasClassType then
           case TPasClassType(LeftTypeEl).ObjKind of
           okClass:
             case TPasClassType(RightTypeEl).ObjKind of
@@ -14920,7 +14953,17 @@ begin
         end
       else if ExprTypeEl.ClassType=TPasClassType then
         begin
-        if ArgTypeEl is TPasClassType then
+        if ArgResolved.BaseType=btString then
+          begin
+          if TPasClassType(ExprTypeEl).ObjKind=okInterface then
+            begin
+            // interface to string  ->  intf.$guid
+            Result:=CreateDotExpression(El,Result,CreatePrimitiveDotExpr(FBuiltInNames[pbivnIntfGUID],El));
+            end
+          else
+            RaiseNotSupported(El,AContext,20180410160008);
+          end
+        else if ArgTypeEl is TPasClassType then
           case TPasClassType(ExprTypeEl).ObjKind of
           okClass:
             case TPasClassType(ArgTypeEl).ObjKind of

packages/pastojs/src/pas2jsfiler.pp

@@ -7502,6 +7502,14 @@ begin
     else
       Src:=aStream;
 
+    {$IFDEF VerbosePCUUncompressed}
+    writeln('TPCUReader.ReadPCU SRC START====================================');
+    SetLength(FirstBytes,Src.Size);
+    Src.read(FirstBytes[1],length(FirstBytes));
+    writeln(FirstBytes);
+    Src.Position:=0;
+    writeln('TPCUReader.ReadPCU SRC END======================================');
+    {$ENDIF}
     JParser:=TJSONParser.Create(Src,[joUTF8,joStrict]);
     Data:=JParser.Parse;
     if not (Data is TJSONObject) then

packages/pastojs/tests/tcmodules.pas

@@ -505,6 +505,7 @@ type
     Procedure TestClassInterface_COM_ArrayOfIntfFail;
     Procedure TestClassInterface_COM_RecordIntfFail;
     Procedure TestClassInterface_COM_UnitInitialization;
+    Procedure TestClassInterface_GUID;
 
     // proc types
     Procedure TestProcType;
@@ -14139,6 +14140,51 @@ begin
     );
 end;
 
+procedure TTestModule.TestClassInterface_GUID;
+begin
+  StartProgram(false);
+  Add([
+  '{$interfaces corba}',
+  'type',
+  '  IUnknown = interface',
+  '    [''{F31DB68F-3010-D355-4EBA-CDD4EF4A737C}'']',
+  '  end;',
+  '  TObject = class end;',
+  '  TGUID = string;',
+  '  TAliasGUID = TGUID;',
+  'procedure DoIt(g: TAliasGUID);',
+  'begin end;',
+  'var i: IUnknown;',
+  '  g: TAliasGUID;',
+  'begin',
+  '  DoIt(IUnknown);',
+  '  DoIt(i);',
+  '  g:=i;',
+  '  g:=IUnknown;',
+  '']);
+  ConvertProgram;
+  CheckSource('TestClassInterface_GUID',
+    LinesToStr([ // statements
+    'rtl.createInterface($mod, "IUnknown", "{F31DB68F-3010-D355-4EBA-CDD4EF4A737C}", [], null);',
+    'rtl.createClass($mod, "TObject", null, function () {',
+    '  this.$init = function () {',
+    '  };',
+    '  this.$final = function () {',
+    '  };',
+    '});',
+    'this.DoIt = function (g) {',
+    '};',
+    'this.i = null;',
+    'this.g = "";',
+    '']),
+    LinesToStr([ // $mod.$main
+    '$mod.DoIt($mod.IUnknown.$guid);',
+    '$mod.DoIt($mod.i.$guid);',
+    '$mod.g = $mod.i.$guid;',
+    '$mod.g = $mod.IUnknown.$guid;',
+    '']));
+end;
+
 procedure TTestModule.TestProcType;
 begin
   StartProgram(false);