* pas2jni: Support for class references.

  - Fixed inclusion of unneeded pointer types.

git-svn-id: trunk@35779 -

utils/pas2jni/def.pas

@@ -31,7 +31,7 @@ uses
 type
   TDefType = (dtNone, dtUnit, dtClass, dtProc, dtField, dtProp, dtParam, dtVar,
               dtType, dtConst, dtProcType, dtEnum, dtSet, dtPointer, dtArray,
-              dtJniObject, dtJniEnv);
+              dtJniObject, dtJniEnv, dtClassRef);
 
   TDefClass = class of TDef;
   { TDef }
@@ -166,7 +166,7 @@ type
   end;
 
   TProcType = (ptProcedure, ptFunction, ptConstructor, ptDestructor);
-  TProcOption = (poOverride, poOverload, poMethodPtr, poPrivate, poProtected);
+  TProcOption = (poOverride, poOverload, poMethodPtr, poPrivate, poProtected, poClassMethod);
   TProcOptions = set of TProcOption;
 
   { TProcDef }
@@ -234,6 +234,20 @@ type
     function GetRefDef2: TDef; override;
   end;
 
+  { TClassRefDef }
+
+  TClassRefDef = class(TDef)
+  private
+    FHasClassRef: boolean;
+  protected
+    procedure SetIsUsed(const AValue: boolean); override;
+  public
+    ClassRef: TDef;
+    procedure ResolveDefs; override;
+    function GetRefDef: TDef; override;
+  end;
+
+
 const
   ReplDefs  = [dtField, dtProp, dtProc];
 
@@ -254,6 +268,25 @@ begin
   Result:=TTypeDef(t1).BasicType = TTypeDef(t2).BasicType;
 end;
 
+{ TClassRefDef }
+
+procedure TClassRefDef.SetIsUsed(const AValue: boolean);
+begin
+  inherited SetIsUsed(AValue);
+  SetExtUsed(ClassRef, AValue, FHasClassRef);
+end;
+
+procedure TClassRefDef.ResolveDefs;
+begin
+  inherited ResolveDefs;
+  ClassRef:=ResolveDef(ClassRef);
+end;
+
+function TClassRefDef.GetRefDef: TDef;
+begin
+  Result:=ClassRef;
+end;
+
 { TArrayDef }
 
 procedure TArrayDef.SetIsUsed(const AValue: boolean);
@@ -472,10 +505,24 @@ end;
 { TVarDef }
 
 procedure TVarDef.SetIsUsed(const AValue: boolean);
+var
+  ptr, d: TDef;
 begin
   if IsPrivate then
     exit;
   inherited SetIsUsed(AValue);
+  // Detect circular pointers
+  if (VarType <> nil) and (VarType.DefType = dtPointer) and (VarType.RefCnt > 0) then begin
+    ptr:=TPointerDef(VarType).PtrType;
+    if ptr <> nil then begin
+      d:=Self;
+      while d <> nil do begin
+        if d = ptr then
+          exit;
+        d:=d.Parent;;
+      end;
+    end;
+  end;
   SetExtUsed(VarType, AValue, FHasTypeRef);
 end;
 

utils/pas2jni/ppuparser.pas

@@ -386,6 +386,9 @@ var
         else
         if jt = 'array' then
           d:=TArrayDef.Create(CurDef, dtArray)
+        else
+        if jt = 'classref' then
+          d:=TClassRefDef.Create(CurDef, dtClassRef)
         else
           continue;
 
@@ -452,7 +455,10 @@ var
                     ProcOpt:=ProcOpt + [poOverload]
                   else
                   if s = 'abstract' then
-                    TClassDef(Parent).HasAbstractMethods:=True;
+                    TClassDef(Parent).HasAbstractMethods:=True
+                  else
+                  if s = 'classmethod' then
+                    ProcOpt:=ProcOpt + [poClassMethod];
                 end;
 
                 ReturnType:=_GetRef(it.Get('RetType', TJSONObject(nil)));
@@ -550,6 +556,10 @@ var
               RangeType:=_GetRef(it.Get('RangeType', TJSONObject(nil)));
               ElType:=_GetRef(it.Get('ElType', TJSONObject(nil)));
             end;
+          dtClassRef:
+            with TClassRefDef(d) do begin
+              ClassRef:=_GetRef(it.Get('Ref', TJSONObject(nil)));;
+            end;
         end;
       end;
   end;

utils/pas2jni/writer.pas

@@ -98,8 +98,10 @@ type
     FThisUnit: TUnitDef;
     FIntegerType: TDef;
     FRecords: TObjectList;
+    FRealClasses: TObjectList;
 
     function DoCheckItem(const ItemName: string): TCheckItemResult;
+    procedure WriteClassTable;
 
     procedure WriteFileComment(st: TTextOutStream);
 
@@ -140,6 +142,7 @@ type
     procedure WriteProcType(d: TProcDef; PreInfo: boolean);
     procedure WriteSet(d: TSetDef);
     procedure WritePointer(d: TPointerDef; PreInfo: boolean);
+    procedure WriteClassRef(d: TClassRefDef; PreInfo: boolean);
     procedure WriteUnit(u: TUnitDef);
     procedure WriteOnLoad;
     procedure WriteRecordSizes;
@@ -188,9 +191,9 @@ const
     'system.fma'
   );
 
-  ExcludeDelphi7: array[1..25] of string = (
+  ExcludeDelphi7: array[1..26] of string = (
     'system.TObject.StringMessageTable', 'system.TObject.GetInterfaceEntryByStr', 'system.TObject.UnitName', 'system.TObject.Equals',
-    'system.TObject.GetHashCode', 'system.TObject.ToString','classes.TStream.ReadByte', 'classes.TStream.ReadWord',
+    'system.TObject.GetHashCode', 'system.TObject.ToString','system.TObject.QualifiedClassName','classes.TStream.ReadByte', 'classes.TStream.ReadWord',
     'classes.TStream.ReadDWord', 'classes.TStream.ReadQWord', 'classes.TStream.ReadAnsiString', 'classes.TStream.WriteByte',
     'classes.TStream.WriteWord', 'classes.TStream.WriteDWord', 'classes.TStream.WriteQWord', 'classes.TStream.WriteAnsiString',
     'classes.TCollection.Exchange', 'classes.TStrings.Equals', 'classes.TStrings.GetNameValue', 'classes.TStrings.ExtractName',
@@ -320,7 +323,7 @@ begin
       case d.DefType of
         dtType:
           Result:=JNIType[TTypeDef(d).BasicType];
-        dtClass, dtEnum:
+        dtClass, dtEnum, dtClassRef:
           Result:='jobject';
         dtProcType:
           if poMethodPtr in TProcDef(d).ProcOpt then
@@ -412,7 +415,7 @@ begin
     case d.DefType of
       dtType:
         Result:=JNITypeSig[TTypeDef(d).BasicType];
-      dtClass, dtProcType, dtSet, dtEnum:
+      dtClass, dtProcType, dtSet, dtEnum, dtClassRef:
         Result:='L' + GetJavaClassPath(d) + ';';
       dtPointer:
         if TPointerDef(d).IsObjPtr then
@@ -437,7 +440,7 @@ begin
       case d.DefType of
         dtType:
           Result:=JavaType[TTypeDef(d).BasicType];
-        dtClass, dtProcType, dtSet, dtEnum:
+        dtClass, dtProcType, dtSet, dtEnum, dtClassRef:
           Result:=d.Name;
         dtPointer:
           if TPointerDef(d).IsObjPtr then
@@ -515,6 +518,7 @@ var
   procedure WriteConstructors;
   var
     cc: TStringList;
+    i: integer;
   begin
     if not TClassDef(d).HasAbstractMethods then begin
       // Writing all constructors including parent's
@@ -526,6 +530,11 @@ var
         cc.Free;
       end;
     end;
+    if d.CType = ctClass then begin
+      i:=FRealClasses.Add(d);
+      Fjs.WriteLn(Format('public static %s Class() { return new %0:s(system.GetClassRef(%d)); }', [d.AliasName, i]));
+      Fjs.WriteLn(Format('public static system.TClass TClass() { return system.GetTClass(%d); }', [i]));
+    end;
   end;
 
   procedure _WriteReplacedItems(c: TClassDef);
@@ -770,6 +779,9 @@ begin
   pi:=TProcInfo.Create;
   with d do
   try
+    IsObj:=(d.Parent.DefType = dtClass) and (TClassDef(d.Parent).CType = ctObject);
+    if not IsObj and (poClassMethod in ProcOpt) and (Name = 'ClassType') then
+      ProcOpt:=ProcOpt - [poClassMethod];
     pi.Name:=Name;
     s:=GetClassPrefix(d.Parent) + pi.Name;
     pi.JniName:=s;
@@ -805,7 +817,6 @@ begin
         s:='procedure';
       s:=s + ' ' + pi.JniName + '(_env: PJNIEnv; _jobj: jobject';
 
-      IsObj:=(d.Parent.DefType = dtClass) and (TClassDef(d.Parent).CType = ctObject);
       if IsObj and (ProcType in [ptConstructor, ptDestructor]) then
         TempRes:='__tempres';
 
@@ -847,6 +858,12 @@ begin
       Fps.WriteLn(s);
       if err then
         exit;
+
+      if (poClassMethod in ProcOpt) and not IsObj then begin
+        Fps.WriteLn(Format('type _classt = %s;', [Parent.Parent.Name + '.' + Parent.Name]));
+        Fps.WriteLn('type _class = class of _classt;');
+      end;
+
       if (tempvars <> nil) or UseTempObjVar or (TempRes <> '') then begin
         s:='';
         Fps.WriteLn('var');
@@ -916,7 +933,10 @@ begin
           if ProcType = ptConstructor then
             s:=Parent.Parent.Name + '.' + Parent.Name + '.'
           else
-            s:=JniToPasType(d.Parent, '_jobj', True) + '.';
+            if (poClassMethod in ProcOpt) and not IsObj then
+              s:='_class(_GetClass(_env, _jobj, ' + GetTypeInfoVar(d.Parent) + '))' + '.'
+            else
+              s:=JniToPasType(d.Parent, '_jobj', True) + '.';
 
       if Variable = nil then begin
         // Regular proc
@@ -1508,6 +1528,26 @@ begin
   Fjs.WriteLn(Format('public %s(long objptr) { super(objptr); }', [d.Name]));
   Fjs.DecI;
   Fjs.WriteLn('}');
+  Fjs.WriteLn;
+end;
+
+procedure TWriter.WriteClassRef(d: TClassRefDef; PreInfo: boolean);
+begin
+  if not d.IsUsed then
+    exit;
+  if PreInfo then begin
+    RegisterPseudoClass(d);
+    WriteClassInfoVar(d);
+    exit;
+  end;
+
+  WriteComment(d, 'class ref');
+  Fjs.WriteLn(Format('public static class %s extends %s {', [d.Name, d.ClassRef.Name]));
+  Fjs.IncI;
+  Fjs.WriteLn(Format('public %s(PascalObject obj) { super(obj); }', [d.Name]));
+  Fjs.DecI;
+  Fjs.WriteLn('}');
+  Fjs.WriteLn;
 end;
 
 procedure TWriter.WriteUnit(u: TUnitDef);
@@ -1636,6 +1676,12 @@ begin
       Fjs.DecI;
       Fjs.WriteLn('}');
 
+      // Class
+      Fjs.WriteLn;
+      Fjs.WriteLn('native static long GetClassRef(int index);');
+      AddNativeMethod(u, '_GetClassRef', 'GetClassRef', '(I)J');
+      Fjs.WriteLn('static TClass GetTClass(int index) { TClass c = new TClass(null); c._pasobj=GetClassRef(index); return c; }');
+
       // Record
       Fjs.WriteLn;
       Fjs.WriteLn('public static class Record extends PascalObjectEx {');
@@ -1996,6 +2042,8 @@ begin
           WriteProcType(TProcDef(d), True);
         dtPointer:
           WritePointer(TPointerDef(d), True);
+        dtClassRef:
+          WriteClassRef(TClassRefDef(d), True);
       end;
     end;
 
@@ -2021,6 +2069,8 @@ begin
           WriteConst(TConstDef(d));
         dtPointer:
           WritePointer(TPointerDef(d), False);
+        dtClassRef:
+          WriteClassRef(TClassRefDef(d), False);
       end;
     end;
 
@@ -2151,6 +2201,7 @@ begin
       if j > 20 then begin
         Fps.WriteLn(s);
         s:='';
+        j:=0;
       end;
       s:=s + IntToStr(TClassDef(FRecords[i]).Size);
     end;
@@ -2166,6 +2217,40 @@ begin
   Fps.WriteLn('end;');
 end;
 
+procedure TWriter.WriteClassTable;
+var
+  i: integer;
+  s,ss: string;
+begin
+  Fps.WriteLn;
+  Fps.WriteLn('function _GetClassRef(env: PJNIEnv; jobj: jobject; index: jint): jlong;' + JniCaliing);
+  if FRealClasses.Count > 0 then begin
+    Fps.WriteLn(Format('const cls: array[0..%d] of TClass =', [FRealClasses.Count - 1]));
+    Fps.IncI;
+    s:='(';
+    for i:=0 to FRealClasses.Count - 1 do begin
+      if i > 0 then
+        s:=s + ',';
+      if Length(s) > 100 then begin
+        Fps.WriteLn(s);
+        s:='';
+      end;
+      with TClassDef(FRealClasses[i]) do
+        ss:=Parent.Name + '.' + Name;
+      s:=s + ss;
+    end;
+    Fps.WriteLn(s + ');');
+    Fps.DecI;
+  end;
+  Fps.WriteLn('begin');
+  if FRealClasses.Count > 0 then
+    s:='cls[index]'
+  else
+    s:='nil';
+  Fps.WriteLn('Result:=-jlong(ptruint(pointer(' + s + ')));', 1);
+  Fps.WriteLn('end;');
+end;
+
 function TWriter.JniToPasType(d: TDef; const v: string; CheckNil: boolean): string;
 var
   n: string;
@@ -2221,6 +2306,11 @@ begin
         else
           Result:=Format('pointer(ptruint(%s))', [Result]);
       end;
+    dtClassRef:
+      begin
+        Result:=Format('_GetClass(_env, %s, %s)', [Result, GetTypeInfoVar(d)]);
+        Result:=Format('%s.%s(%s)', [d.Parent.Name, d.Name, Result]);
+      end;
   end;
 end;
 
@@ -2266,6 +2356,8 @@ begin
         Result:=Format('_CreateJavaObj(_env, %s, %s)', [Result, GetTypeInfoVar(d)])
       else
         Result:=Format('ptruint(pointer(%s))', [Result]);
+    dtClassRef:
+      Result:=Format('_CreateJavaObj(_env, -jlong(ptruint(pointer(%s))), %s)', [Result, GetTypeInfoVar(d)])
   end;
 end;
 
@@ -2636,6 +2728,7 @@ begin
 
   FThisUnit:=TUnitDef.Create(nil, dtUnit);
   FRecords:=TObjectList.Create(False);
+  FRealClasses:=TObjectList.Create(False);
 end;
 
 function DoCanUseDef(def, refdef: TDef): boolean;
@@ -2659,6 +2752,7 @@ begin
   ExcludeList.Free;
   FThisUnit.Free;
   FRecords.Free;
+  FRealClasses.Free;
   inherited Destroy;
 end;
 
@@ -2807,13 +2901,13 @@ begin
     Fps.WriteLn('end;');
 
     Fps.WriteLn;
-    Fps.WriteLn('function _CreateJavaObj(env: PJNIEnv; PasObj: pointer; const ci: _TJavaClassInfo; cleanup: boolean = True): jobject;');
+    Fps.WriteLn('function _CreateJavaObj(env: PJNIEnv; PasObj: jlong; const ci: _TJavaClassInfo; cleanup: boolean = True): jobject; overload;');
     Fps.WriteLn('var v: array [0..1] of jvalue;');
     Fps.WriteLn('begin');
     Fps.IncI;
     Fps.WriteLn('Result:=nil;');
-    Fps.WriteLn('if PasObj = nil then exit;');
-    Fps.WriteLn('v[0].J:=Int64(ptruint(PasObj));');
+    Fps.WriteLn('if PasObj = 0 then exit;');
+    Fps.WriteLn('v[0].J:=PasObj;');
     Fps.WriteLn('if ci.ConstrId = nil then begin');
     Fps.WriteLn('Result:=env^^.AllocObject(env, ci.ClassRef);', 1);
     Fps.WriteLn('if Result = nil then exit;', 1);
@@ -2824,6 +2918,12 @@ begin
     Fps.WriteLn('end;');
     Fps.DecI;
     Fps.WriteLn('end;');
+    Fps.WriteLn;
+    Fps.WriteLn('function _CreateJavaObj(env: PJNIEnv; PasObj: pointer; const ci: _TJavaClassInfo; cleanup: boolean = True): jobject; overload;');
+    Fps.WriteLn('begin');
+    Fps.WriteLn('Result:=_CreateJavaObj(env, jlong(ptruint(PasObj)), ci, cleanup)', 1);
+    Fps.WriteLn('end;');
+    Fps.WriteLn;
 
     Fps.WriteLn;
     Fps.WriteLn('function _GetPasObj(env: PJNIEnv; jobj: jobject; const ci: _TJavaClassInfo; CheckNil: boolean): pointer;');
@@ -2840,6 +2940,22 @@ begin
     Fps.DecI;
     Fps.WriteLn('end;');
 
+    Fps.WriteLn;
+    Fps.WriteLn('function _GetClass(env: PJNIEnv; jobj: jobject; const ci: _TJavaClassInfo): TClass;');
+    Fps.WriteLn('var pasobj: jlong;');
+    Fps.WriteLn('begin');
+    Fps.IncI;
+    Fps.WriteLn('if jobj <> nil then');
+    Fps.WriteLn('pasobj:=env^^.GetLongField(env, jobj, ci.ObjFieldId)', 1);
+    Fps.WriteLn('else');
+    Fps.WriteLn('pasobj:=0;', 1);
+    Fps.WriteLn('if pasobj > 0 then');
+    Fps.WriteLn('Result:=TObject(ptruint(pasobj)).ClassType', 1);
+    Fps.WriteLn('else');
+    Fps.WriteLn('Result:=TClass(ptruint(-pasobj));', 1);
+    Fps.DecI;
+    Fps.WriteLn('end;');
+
     Fps.WriteLn;
     Fps.WriteLn('procedure _HandleJNIException(env: PJNIEnv);');
     Fps.WriteLn('begin');
@@ -2898,6 +3014,7 @@ begin
       end;
 
     WriteRecordSizes;
+    WriteClassTable;
 
     WriteOnLoad;