mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-06-05 12:58:29 +02:00
* pas2jni: Support for class references.
- Fixed inclusion of unneeded pointer types. git-svn-id: trunk@35779 -
This commit is contained in:
yury
parent
13b73244b3
commit
252f9ef153
@ -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;
|
||||
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user