pastojs: atypeinfo:=pointer

git-svn-id: trunk@39310 -

packages/pastojs/src/fppas2js.pp

@@ -3452,6 +3452,7 @@ var
   LArray: TPasArrayType;
   ElTypeResolved: TPasResolverResult;
   LTypeEl, RTypeEl: TPasType;
+  TIName: String;
 begin
   Result:=cIncompatible;
   //writeln('TPas2JSResolver.CheckAssignCompatibilityCustom ',GetResolverResultDbg(LHS));
@@ -3514,6 +3515,20 @@ begin
         Handled:=true;
         Result:=cJSValueConversion;
         end;
+      end
+    else if (LTypeEl.ClassType=TPasClassType)
+        and (rrfReadable in RHS.Flags)
+        and (RHS.BaseType=btPointer)
+        and IsSameType(RTypeEl,BaseTypes[btPointer],prraNone)
+        then
+      begin
+      TIName:=Pas2JSBuiltInNames[pbivnRTL]+'.'+Pas2JSBuiltInNames[pbitnTI];
+      if IsExternalClass_Name(TPasClassType(LTypeEl),TIName) then
+        begin
+        // aTTypeInfo:=aPointer
+        Handled:=true;
+        Result:=cTypeConversion;
+        end;
       end;
     end;
 
@@ -4008,7 +4023,7 @@ begin
           begin
           if (FromResolved.BaseType in btAllJSStringAndChars) then
             begin
-            if IsExternalClassName(ToClass,'String') then
+            if IsExternalClass_Name(ToClass,'String') then
               // TJSString(aString)
               exit(cExact);
             end
@@ -4017,27 +4032,27 @@ begin
             FromTypeEl:=FromResolved.LoTypeEl;
             if FromTypeEl.ClassType=TPasArrayType then
               begin
-              if IsExternalClassName(ToClass,'Array')
-                  or IsExternalClassName(ToClass,'Object') then
+              if IsExternalClass_Name(ToClass,'Array')
+                  or IsExternalClass_Name(ToClass,'Object') then
                 // TJSArray(AnArray)  or  TJSObject(AnArray)
                 exit(cExact);
               end
             else if FromTypeEl.ClassType=TPasRecordType then
               begin
-              if IsExternalClassName(ToClass,'Object') then
+              if IsExternalClass_Name(ToClass,'Object') then
                 // TJSObject(aRecord)
                 exit(cExact);
               end
             else if FromTypeEl.ClassType=TPasClassOfType then
               begin
-              if IsExternalClassName(ToClass,'Object') then
+              if IsExternalClass_Name(ToClass,'Object') then
                 // TJSObject(ImgClass)
                 exit(cExact);
               end
             else if FromTypeEl.InheritsFrom(TPasProcedureType) then
               begin
-              if IsExternalClassName(ToClass,'Function')
-                  or IsExternalClassName(ToClass,'Object') then
+              if IsExternalClass_Name(ToClass,'Function')
+                  or IsExternalClass_Name(ToClass,'Object') then
                 // TJSFunction(@Proc) or TJSFunction(ProcVar)
                 exit(cExact);
               end;
@@ -4051,8 +4066,8 @@ begin
           FromTypeEl:=FromResolved.LoTypeEl;
           if (FromTypeEl.ClassType=TPasClassType)
               and TPasClassType(FromTypeEl).IsExternal
-              and (IsExternalClassName(TPasClassType(FromTypeEl),'Array')
-                or IsExternalClassName(TPasClassType(FromTypeEl),'Object')) then
+              and (IsExternalClass_Name(TPasClassType(FromTypeEl),'Array')
+                or IsExternalClass_Name(TPasClassType(FromTypeEl),'Object')) then
             begin
             // type cast external Array/Object to an array
             exit(cCompatible);
@@ -4084,7 +4099,7 @@ begin
           FromTypeEl:=FromResolved.LoTypeEl;
           if FromTypeEl.ClassType=TPasClassType then
             begin
-            if IsExternalClassName(TPasClassType(FromTypeEl),'Function') then
+            if IsExternalClass_Name(TPasClassType(FromTypeEl),'Function') then
               // TProcType(aJSFunction)
               exit(cCompatible);
             end;

packages/pastojs/tests/tcmodules.pas

@@ -684,6 +684,7 @@ type
     Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses2;
     Procedure TestRTTI_TypeInfo_ExtTypeInfoClasses3;
     Procedure TestRTTI_TypeInfo_FunctionClassType;
+    Procedure TestRTTI_TypeInfo_MixedUnits_PointerAndClass;
     Procedure TestRTTI_Interface_Corba;
     Procedure TestRTTI_Interface_COM;
 
@@ -20894,33 +20895,34 @@ procedure TTestModule.TestRTTI_TypeInfo_ExtTypeInfoClasses1;
 begin
   Converter.Options:=Converter.Options-[coNoTypeInfo];
   StartProgram(false);
-  Add('{$modeswitch externalclass}');
-  Add('type');
-  Add('  TTypeInfo = class external name ''rtl.tTypeInfo'' end;');
-  Add('  TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo) end;');
-  Add('  TFlag = (up,down);');
-  Add('  TTypeInfoEnum = class external name ''rtl.tTypeInfoEnum''(TTypeInfoInteger) end;');
-  Add('  TFlags = set of TFlag;');
-  Add('  TTypeInfoSet = class external name ''rtl.tTypeInfoSet''(TTypeInfo) end;');
-  Add('var');
-  Add('  ti: TTypeInfo;');
-  Add('  tiInt: TTypeInfoInteger;');
-  Add('  tiEnum: TTypeInfoEnum;');
-  Add('  tiSet: TTypeInfoSet;');
-  Add('begin');
-  Add('  ti:=typeinfo(string);');
-  Add('  ti:=typeinfo(boolean);');
-  Add('  ti:=typeinfo(char);');
-  Add('  ti:=typeinfo(double);');
-  Add('  tiInt:=typeinfo(shortint);');
-  Add('  tiInt:=typeinfo(byte);');
-  Add('  tiInt:=typeinfo(smallint);');
-  Add('  tiInt:=typeinfo(word);');
-  Add('  tiInt:=typeinfo(longint);');
-  Add('  tiInt:=typeinfo(longword);');
-  Add('  ti:=typeinfo(jsvalue);');
-  Add('  tiEnum:=typeinfo(tflag);');
-  Add('  tiSet:=typeinfo(tflags);');
+  Add([
+  '{$modeswitch externalclass}',
+  'type',
+  '  TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
+  '  TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo) end;',
+  '  TFlag = (up,down);',
+  '  TTypeInfoEnum = class external name ''rtl.tTypeInfoEnum''(TTypeInfoInteger) end;',
+  '  TFlags = set of TFlag;',
+  '  TTypeInfoSet = class external name ''rtl.tTypeInfoSet''(TTypeInfo) end;',
+  'var',
+  '  ti: TTypeInfo;',
+  '  tiInt: TTypeInfoInteger;',
+  '  tiEnum: TTypeInfoEnum;',
+  '  tiSet: TTypeInfoSet;',
+  'begin',
+  '  ti:=typeinfo(string);',
+  '  ti:=typeinfo(boolean);',
+  '  ti:=typeinfo(char);',
+  '  ti:=typeinfo(double);',
+  '  tiInt:=typeinfo(shortint);',
+  '  tiInt:=typeinfo(byte);',
+  '  tiInt:=typeinfo(smallint);',
+  '  tiInt:=typeinfo(word);',
+  '  tiInt:=typeinfo(longint);',
+  '  tiInt:=typeinfo(longword);',
+  '  ti:=typeinfo(jsvalue);',
+  '  tiEnum:=typeinfo(tflag);',
+  '  tiSet:=typeinfo(tflags);']);
   ConvertProgram;
   CheckSource('TestRTTI_TypeInfo_ExtTypeInfoClasses1',
     LinesToStr([ // statements
@@ -21172,6 +21174,86 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestRTTI_TypeInfo_MixedUnits_PointerAndClass;
+begin
+  Converter.Options:=Converter.Options-[coNoTypeInfo];
+  AddModuleWithIntfImplSrc('typinfo.pas',
+    LinesToStr([
+    '{$modeswitch externalclass}',
+    'type',
+    '  TTypeInfo = class external name ''rtl.tTypeInfo'' end;',
+    '  TTypeInfoInteger = class external name ''rtl.tTypeInfoInteger''(TTypeInfo) end;',
+    '']),
+    '');
+  AddModuleWithIntfImplSrc('unit2.pas',
+    LinesToStr([
+    'uses typinfo;',
+    'type PTypeInfo = TTypeInfo;', // delphi compatibility code
+    'procedure DoPtr(p: PTypeInfo);',
+    'procedure DoInfo(t: TTypeInfo);',
+    'procedure DoInt(t: TTypeInfoInteger);',
+    '']),
+    LinesToStr([
+    'procedure DoPtr(p: PTypeInfo);',
+    'begin end;',
+    'procedure DoInfo(t: TTypeInfo);',
+    'begin end;',
+    'procedure DoInt(t: TTypeInfoInteger);',
+    'begin end;',
+    '']));
+  StartUnit(true);
+  Add([
+  'interface',
+  'uses unit2;', // does not use unit typinfo
+  'implementation',
+  'var',
+  '  i: byte;',
+  '  p: pointer;',
+  '  t: PTypeInfo;',
+  'initialization',
+  '  p:=typeinfo(i);',
+  '  t:=typeinfo(i);',
+  '  if p=t then ;',
+  '  if p=typeinfo(i) then ;',
+  '  if typeinfo(i)=p then ;',
+  '  if t=typeinfo(i) then ;',
+  '  if typeinfo(i)=t then ;',
+  '  DoPtr(p);',
+  '  DoPtr(t);',
+  '  DoPtr(typeinfo(i));',
+  '  DoInfo(p);',
+  '  DoInfo(t);',
+  '  DoInfo(typeinfo(i));',
+  '  DoInt(typeinfo(i));',
+  '']);
+  ConvertUnit;
+  CheckSource('TestRTTI_TypeInfo_MixedUnits_PointerAndClass',
+    LinesToStr([ // statements
+    'var $impl = $mod.$impl;',
+    '']),
+    LinesToStr([ // this.$init
+    '$impl.p = rtl.byte;',
+    '$impl.t = rtl.byte;',
+    'if ($impl.p === $impl.t) ;',
+    'if ($impl.p === rtl.byte) ;',
+    'if (rtl.byte === $impl.p) ;',
+    'if ($impl.t === rtl.byte) ;',
+    'if (rtl.byte === $impl.t) ;',
+    'pas.unit2.DoPtr($impl.p);',
+    'pas.unit2.DoPtr($impl.t);',
+    'pas.unit2.DoPtr(rtl.byte);',
+    'pas.unit2.DoInfo($impl.p);',
+    'pas.unit2.DoInfo($impl.t);',
+    'pas.unit2.DoInfo(rtl.byte);',
+    'pas.unit2.DoInt(rtl.byte);',
+    '']),
+    LinesToStr([ // implementation
+    '$impl.i = 0;',
+    '$impl.p = null;',
+    '$impl.t = null;',
+    '']) );
+end;
+
 procedure TTestModule.TestRTTI_Interface_Corba;
 begin
   Converter.Options:=Converter.Options-[coNoTypeInfo];