|
|
@@ -0,0 +1,2156 @@
|
|
|
+{
|
|
|
+ pas2jni - JNI bridge generator for Pascal.
|
|
|
+
|
|
|
+ Copyright (c) 2013 by Yury Sidorov.
|
|
|
+
|
|
|
+ This program is free software; you can redistribute it and/or modify
|
|
|
+ it under the terms of the GNU General Public License as published by
|
|
|
+ the Free Software Foundation; either version 2 of the License, or
|
|
|
+ (at your option) any later version.
|
|
|
+
|
|
|
+ This program is distributed in the hope that it will be useful,
|
|
|
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
+ GNU General Public License for more details.
|
|
|
+
|
|
|
+ You should have received a copy of the GNU General Public License
|
|
|
+ along with this program; if not, write to the Free Software
|
|
|
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
+
|
|
|
+ ****************************************************************************}
|
|
|
+
|
|
|
+unit writer;
|
|
|
+
|
|
|
+{$mode objfpc}{$H+}
|
|
|
+
|
|
|
+interface
|
|
|
+
|
|
|
+{$define DEBUG}
|
|
|
+
|
|
|
+{$ifdef DEBUG}
|
|
|
+{$ASSERTIONS ON}
|
|
|
+{$endif}
|
|
|
+
|
|
|
+uses
|
|
|
+ Classes, SysUtils, def, contnrs, PPUParser;
|
|
|
+
|
|
|
+const
|
|
|
+ MaxMethodPointers = 10000;
|
|
|
+
|
|
|
+type
|
|
|
+ { TTextOutStream }
|
|
|
+
|
|
|
+ TTextOutStream = class(TFileStream)
|
|
|
+ private
|
|
|
+ FIndent: integer;
|
|
|
+ FIndStr: string;
|
|
|
+ procedure SetIndednt(const AValue: integer);
|
|
|
+ public
|
|
|
+ procedure Write(const s: ansistring); overload;
|
|
|
+ procedure WriteLn(const s: ansistring = ''; ExtraIndent: integer = 0);
|
|
|
+ procedure IncI;
|
|
|
+ procedure DecI;
|
|
|
+ property Indent: integer read FIndent write SetIndednt;
|
|
|
+ property SIndent: string read FIndStr;
|
|
|
+ end;
|
|
|
+
|
|
|
+ { TWriter }
|
|
|
+
|
|
|
+ TWriter = class
|
|
|
+ private
|
|
|
+ Fjs, Fps: TTextOutStream;
|
|
|
+ FClasses: TStringList;
|
|
|
+ FPkgDir: string;
|
|
|
+ FUniqueCnt: integer;
|
|
|
+ FThisUnit: TUnitDef;
|
|
|
+
|
|
|
+ function DoCheckItem(const ItemName: string): TCheckItemResult;
|
|
|
+
|
|
|
+ procedure ProcessRules(d: TDef; const Prefix: string = '');
|
|
|
+ function GetUniqueNum: integer;
|
|
|
+ function DefToJniType(d: TDef; var err: boolean): string;
|
|
|
+ function DefToJniSig(d: TDef): string;
|
|
|
+ function DefToJavaType(d: TDef): string;
|
|
|
+ function GetJavaClassPath(d: TDef; const AClassName: string = ''): string;
|
|
|
+ function JniToPasType(d: TDef; const v: string; CheckNil: boolean): string;
|
|
|
+ function PasToJniType(d: TDef; const v: string): string;
|
|
|
+ function GetTypeInfoVar(ClassDef: TDef): string;
|
|
|
+ function GetClassPrefix(ClassDef: TDef; const AClassName: string = ''): string;
|
|
|
+ function IsJavaSimpleType(d: TDef): boolean;
|
|
|
+ function GetProcDeclaration(d: TProcDef; const ProcName: string = ''): string;
|
|
|
+ function GetJavaProcDeclaration(d: TProcDef; const ProcName: string = ''): string;
|
|
|
+ function GetJniFuncType(d: TDef): string;
|
|
|
+ function GetJavaClassName(cls: TDef; it: TDef): string;
|
|
|
+ procedure RegisterPseudoClass(d: TDef);
|
|
|
+ function GetPasIntType(Size: integer): string;
|
|
|
+// procedure AddCustomProc(ParentDef: TDef; const JniName, Name: string; RetType: TBasicType; const Params: array of TBasicType);
|
|
|
+ function AddCustomProc(ParentDef: TDef; const JniName, Name: string; RetType: TBasicType; const Params: array of TBasicType): TProcDef;
|
|
|
+ procedure AddNativeMethod(ParentDef: TDef; const JniName, Name, Signature: string);
|
|
|
+ function GetProcSignature(d: TProcDef): string;
|
|
|
+ procedure EHandlerStart;
|
|
|
+ procedure EHandlerEnd(const EnvVarName: string; const ExtraCode: string = '');
|
|
|
+
|
|
|
+ procedure WriteClassInfoVar(d: TDef);
|
|
|
+ procedure WriteComment(d: TDef; const AType: string);
|
|
|
+ procedure WriteClass(d: TDef; PreInfo: boolean);
|
|
|
+ procedure WriteProc(d: TProcDef; Variable: TVarDef = nil; AParent: TDef = nil);
|
|
|
+ procedure WriteVar(d: TVarDef; AParent: TDef = nil);
|
|
|
+ procedure WriteConst(d: TConstDef);
|
|
|
+ procedure WriteEnum(d: TDef);
|
|
|
+ procedure WriteProcType(d: TProcDef; PreInfo: boolean);
|
|
|
+ procedure WriteSet(d: TSetDef);
|
|
|
+ procedure WriteUnit(u: TUnitDef);
|
|
|
+ procedure WriteOnLoad;
|
|
|
+ public
|
|
|
+ SearchPath: string;
|
|
|
+ LibName: string;
|
|
|
+ JavaPackage: string;
|
|
|
+ Units: TStringList;
|
|
|
+ OutPath: string;
|
|
|
+ JavaOutPath: string;
|
|
|
+ IncludeList: TStringList;
|
|
|
+ ExcludeList: TStringList;
|
|
|
+
|
|
|
+ constructor Create;
|
|
|
+ destructor Destroy; override;
|
|
|
+ procedure ProcessUnits;
|
|
|
+ end;
|
|
|
+
|
|
|
+implementation
|
|
|
+
|
|
|
+const
|
|
|
+ JNIType: array[TBasicType] of string =
|
|
|
+ ('', 'jshort', 'jbyte', 'jint', 'jshort', 'jlong', 'jint', 'jlong', 'jfloat', 'jdouble', 'jstring',
|
|
|
+ 'jstring', 'jboolean', 'jchar', 'jchar', 'jint', 'jlong', 'jstring');
|
|
|
+ JNITypeSig: array[TBasicType] of string =
|
|
|
+ ('V', 'S', 'B', 'I', 'S', 'J', 'I', 'J', 'F', 'D', 'Ljava/lang/String;', 'Ljava/lang/String;',
|
|
|
+ 'Z', 'C', 'C', 'I', 'J', 'Ljava/lang/String;');
|
|
|
+ JavaType: array[TBasicType] of string =
|
|
|
+ ('void', 'short', 'byte', 'int', 'short', 'long', 'int', 'long', 'float', 'double', 'String',
|
|
|
+ 'String', 'boolean', 'char', 'char', 'int', 'long', 'String');
|
|
|
+
|
|
|
+ TextIndent = 2;
|
|
|
+
|
|
|
+ ExcludeStd: array[1..43] of string = (
|
|
|
+ 'classes.TStream.ReadComponent', 'classes.TStream.ReadComponentRes', 'classes.TStream.WriteComponent', 'classes.TStream.WriteComponentRes',
|
|
|
+ 'classes.TStream.WriteDescendent', 'classes.TStream.WriteDescendentRes', 'classes.TStream.WriteResourceHeader', 'classes.TStream.FixupResourceHeader',
|
|
|
+ 'classes.TStream.ReadResHeader', 'classes.TComponent.WriteState', 'classes.TComponent.ExecuteAction', 'classes.TComponent.UpdateAction',
|
|
|
+ 'classes.TComponent.GetEnumerator', 'classes.TComponent.VCLComObject', 'classes.TComponent.DesignInfo', 'classes.TComponent.Destroying',
|
|
|
+ 'classes.TComponent.FreeNotification', 'classes.TComponent.RemoveFreeNotification', 'classes.TComponent.FreeOnRelease', 'classes.TComponent.SetSubComponent',
|
|
|
+ 'system.TObject.newinstance', 'system.TObject.FreeInstance', 'system.TObject.SafeCallException', 'system.TObject.InitInstance',
|
|
|
+ 'system.TObject.CleanupInstance', 'system.TObject.ClassInfo', 'system.TObject.AfterConstruction', 'system.TObject.BeforeDestruction',
|
|
|
+ 'system.TObject.GetInterfaceEntry', 'system.TObject.GetInterfaceTable', 'system.TObject.MethodAddress', 'system.TObject.MethodName',
|
|
|
+ 'system.TObject.FieldAddress', 'classes.TComponent.ComponentState', 'classes.TComponent.ComponentStyle', 'classes.TList.GetEnumerator',
|
|
|
+ 'classes.TList.List', 'classes.TList.FPOAttachObserver', 'classes.TList.FPODetachObserver', 'classes.TList.FPONotifyObservers',
|
|
|
+ 'classes.TPersistent.FPOAttachObserver', 'classes.TPersistent.FPODetachObserver', 'classes.TPersistent.FPONotifyObservers'
|
|
|
+ );
|
|
|
+
|
|
|
+ ExcludeDelphi7: array[1..25] 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',
|
|
|
+ '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',
|
|
|
+ 'classes.TStrings.TextLineBreakStyle', 'classes.TStrings.StrictDelimiter', 'classes.TStrings.GetEnumerator', 'classes.TStringList.OwnsObjects',
|
|
|
+ 'classes.TList.AddList'
|
|
|
+ );
|
|
|
+
|
|
|
+ SUnsupportedType = '<unsupported type>';
|
|
|
+
|
|
|
+function JniCaliing: string;
|
|
|
+begin
|
|
|
+ Result:='{$ifdef windows} stdcall {$else} cdecl {$endif};';
|
|
|
+end;
|
|
|
+
|
|
|
+{ TTextOutStream }
|
|
|
+
|
|
|
+procedure TTextOutStream.SetIndednt(const AValue: integer);
|
|
|
+begin
|
|
|
+ if FIndent = AValue then exit;
|
|
|
+ FIndent:=AValue;
|
|
|
+ SetLength(FIndStr, FIndent*TextIndent);
|
|
|
+ if FIndent > 0 then
|
|
|
+ FillChar(FIndStr[1], FIndent*TextIndent, ' ');
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TTextOutStream.Write(const s: ansistring);
|
|
|
+begin
|
|
|
+ WriteBuffer(PChar(s)^, Length(s));
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TTextOutStream.WriteLn(const s: ansistring; ExtraIndent: integer);
|
|
|
+begin
|
|
|
+ if s = '' then
|
|
|
+ Write(LineEnding)
|
|
|
+ else begin
|
|
|
+ Indent:=Indent + ExtraIndent;
|
|
|
+ try
|
|
|
+ Write(FIndStr + s + LineEnding);
|
|
|
+ finally
|
|
|
+ Indent:=Indent - ExtraIndent;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TTextOutStream.IncI;
|
|
|
+begin
|
|
|
+ Indent:=Indent + 1;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TTextOutStream.DecI;
|
|
|
+begin
|
|
|
+ if Indent > 0 then
|
|
|
+ Indent:=Indent - 1;
|
|
|
+end;
|
|
|
+
|
|
|
+type
|
|
|
+ { TClassInfo }
|
|
|
+ TClassInfo = class
|
|
|
+ public
|
|
|
+ Def: TDef;
|
|
|
+ Funcs: TObjectList;
|
|
|
+ IsCommonClass: boolean;
|
|
|
+ constructor Create;
|
|
|
+ destructor Destroy; override;
|
|
|
+ end;
|
|
|
+
|
|
|
+ TProcInfo = class
|
|
|
+ public
|
|
|
+ Name: string;
|
|
|
+ JniName: string;
|
|
|
+ JniSignature: string;
|
|
|
+ end;
|
|
|
+
|
|
|
+{ TClassInfo }
|
|
|
+
|
|
|
+constructor TClassInfo.Create;
|
|
|
+begin
|
|
|
+ Funcs:=TObjectList.Create(True);
|
|
|
+end;
|
|
|
+
|
|
|
+destructor TClassInfo.Destroy;
|
|
|
+begin
|
|
|
+ Funcs.Free;
|
|
|
+ inherited Destroy;
|
|
|
+end;
|
|
|
+
|
|
|
+{ TWriter }
|
|
|
+
|
|
|
+function TWriter.DefToJniType(d: TDef; var err: boolean): string;
|
|
|
+begin
|
|
|
+ if d = nil then begin
|
|
|
+ Result:=SUnsupportedType;
|
|
|
+ err:=True;
|
|
|
+ end
|
|
|
+ else begin
|
|
|
+ if not d.IsUsed then begin
|
|
|
+ Result:='<excluded type> ' + d.Name;
|
|
|
+ err:=True;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ case d.DefType of
|
|
|
+ dtType:
|
|
|
+ Result:=JNIType[TTypeDef(d).BasicType];
|
|
|
+ dtClass, dtRecord, dtEnum:
|
|
|
+ Result:='jobject';
|
|
|
+ dtProcType:
|
|
|
+ if poMethodPtr in TProcDef(d).ProcOpt then
|
|
|
+ Result:='jobject'
|
|
|
+ else begin
|
|
|
+ Result:=SUnsupportedType + ' ' + d.Name;
|
|
|
+ err:=True;
|
|
|
+ end;
|
|
|
+ dtSet:
|
|
|
+ if TSetDef(d).Size <= 4 then
|
|
|
+ Result:='jobject'
|
|
|
+ else begin
|
|
|
+ Result:=SUnsupportedType + ' ' + d.Name;
|
|
|
+ err:=True;
|
|
|
+ end;
|
|
|
+ else begin
|
|
|
+ Result:=SUnsupportedType + ' ' + d.Name;
|
|
|
+ err:=True;
|
|
|
+ d.SetNotUsed;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+function TWriter.DoCheckItem(const ItemName: string): TCheckItemResult;
|
|
|
+begin
|
|
|
+ if IncludeList.IndexOf(ItemName) >= 0 then
|
|
|
+ Result:=crInclude
|
|
|
+ else
|
|
|
+ if ExcludeList.IndexOf(ItemName) >= 0 then
|
|
|
+ Result:=crExclude
|
|
|
+ else
|
|
|
+ Result:=crDefault;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TWriter.ProcessRules(d: TDef; const Prefix: string);
|
|
|
+var
|
|
|
+ i: integer;
|
|
|
+ s: string;
|
|
|
+begin
|
|
|
+ s:=Prefix + d.Name;
|
|
|
+ i:=IncludeList.IndexOf(s);
|
|
|
+ if i >= 0 then begin
|
|
|
+ i:=ptruint(IncludeList.Objects[i]);
|
|
|
+ if (i = 0) or (d.Count = i - 1) then
|
|
|
+ d.IsUsed:=True;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ if ExcludeList.IndexOf(s) >= 0 then begin
|
|
|
+ d.SetNotUsed;
|
|
|
+ end;
|
|
|
+ if not (d.DefType in [dtUnit, dtClass, dtRecord]) then
|
|
|
+ exit;
|
|
|
+ s:=s + '.';
|
|
|
+ for i:=0 to d.Count - 1 do
|
|
|
+ ProcessRules(d[i], s);
|
|
|
+end;
|
|
|
+
|
|
|
+function TWriter.GetUniqueNum: integer;
|
|
|
+begin
|
|
|
+ Inc(FUniqueCnt);
|
|
|
+ Result:=FUniqueCnt;
|
|
|
+end;
|
|
|
+
|
|
|
+function TWriter.DefToJniSig(d: TDef): string;
|
|
|
+begin
|
|
|
+ if d = nil then
|
|
|
+ Result:=SUnsupportedType
|
|
|
+ else
|
|
|
+ case d.DefType of
|
|
|
+ dtType:
|
|
|
+ Result:=JNITypeSig[TTypeDef(d).BasicType];
|
|
|
+ dtClass, dtRecord, dtProcType, dtSet, dtEnum:
|
|
|
+ Result:='L' + GetJavaClassPath(d) + ';';
|
|
|
+ else
|
|
|
+ Result:=SUnsupportedType;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+function TWriter.DefToJavaType(d: TDef): string;
|
|
|
+begin
|
|
|
+ if d = nil then
|
|
|
+ Result:=SUnsupportedType
|
|
|
+ else
|
|
|
+ case d.DefType of
|
|
|
+ dtType:
|
|
|
+ Result:=JavaType[TTypeDef(d).BasicType];
|
|
|
+ dtClass, dtRecord, dtProcType, dtSet, dtEnum:
|
|
|
+ Result:=d.Name;
|
|
|
+ else
|
|
|
+ Result:=SUnsupportedType;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+function TWriter.GetJavaClassPath(d: TDef; const AClassName: string): string;
|
|
|
+var
|
|
|
+ n: string;
|
|
|
+begin
|
|
|
+ if AClassName = '' then
|
|
|
+ n:=d.AliasName
|
|
|
+ else
|
|
|
+ n:=AClassName;
|
|
|
+ Result:=StringReplace(JavaPackage, '.', '/', [rfReplaceAll]);
|
|
|
+ if Result <> '' then
|
|
|
+ Result:=Result + '/';
|
|
|
+ if d.DefType = dtUnit then
|
|
|
+ Result:=Result + n
|
|
|
+ else
|
|
|
+ Result:=Result + d.Parent.AliasName + '$' + n;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TWriter.WriteClass(d: TDef; PreInfo: boolean);
|
|
|
+var
|
|
|
+ WrittenItems: TList;
|
|
|
+
|
|
|
+ procedure _WriteConstructors(c: TClassDef; Written: TStringList);
|
|
|
+ var
|
|
|
+ i, j: integer;
|
|
|
+ p: TProcDef;
|
|
|
+ OldRet: TDef;
|
|
|
+ s: string;
|
|
|
+ begin
|
|
|
+ if c = nil then
|
|
|
+ exit;
|
|
|
+ for i:=0 to c.Count - 1 do
|
|
|
+ with c[i] do begin
|
|
|
+ if (DefType = dtProc) and not c.IsPrivate and (TProcDef(c[i]).ProcType = ptConstructor) then begin
|
|
|
+ p:=TProcDef(c[i]);
|
|
|
+ j:=Written.IndexOf(p.Name);
|
|
|
+ if (j < 0) or (Written.Objects[j] = c) then begin
|
|
|
+ s:=p.Name + ':';
|
|
|
+ for j:=0 to p.Count - 1 do
|
|
|
+ s:=s + DefToJniSig(p[j]);
|
|
|
+ if Written.IndexOf(s) < 0 then begin
|
|
|
+ OldRet:=p.ReturnType;
|
|
|
+ p.ReturnType:=d;
|
|
|
+ p.Parent:=d;
|
|
|
+ try
|
|
|
+ WriteProc(p);
|
|
|
+ finally
|
|
|
+ p.ReturnType:=OldRet;
|
|
|
+ p.Parent:=c;
|
|
|
+ end;
|
|
|
+ Written.Add(s);
|
|
|
+ if not (poOverload in p.ProcOpt) then
|
|
|
+ Written.AddObject(p.Name, c);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ _WriteConstructors(c.AncestorClass, Written);
|
|
|
+ end;
|
|
|
+
|
|
|
+ procedure WriteConstructors;
|
|
|
+ var
|
|
|
+ cc: TStringList;
|
|
|
+ begin
|
|
|
+ if not TClassDef(d).HasAbstractMethods then begin
|
|
|
+ // Writing all constructors including parent's
|
|
|
+ cc:=TStringList.Create;
|
|
|
+ try
|
|
|
+ cc.Sorted:=True;
|
|
|
+ _WriteConstructors(TClassDef(d), cc);
|
|
|
+ finally
|
|
|
+ cc.Free;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ procedure _WriteReplacedItems(c: TClassDef);
|
|
|
+ var
|
|
|
+ i: integer;
|
|
|
+ p: TReplDef;
|
|
|
+ begin
|
|
|
+ c:=c.AncestorClass;
|
|
|
+ if c = nil then
|
|
|
+ exit;
|
|
|
+ if c.HasReplacedItems then begin
|
|
|
+ for i:=0 to c.Count - 1 do
|
|
|
+ with c[i] do begin
|
|
|
+ p:=TReplDef(c[i]);
|
|
|
+ if (DefType in ReplDefs) and ((p.IsReplaced) or p.IsReplImpl) then begin
|
|
|
+ if p.ReplacedItem <> nil then
|
|
|
+ WrittenItems.Add(p.ReplacedItem);
|
|
|
+ if WrittenItems.IndexOf(p) >= 0 then
|
|
|
+ continue;
|
|
|
+ case p.DefType of
|
|
|
+ dtProc:
|
|
|
+ WriteProc(TProcDef(p), nil, d);
|
|
|
+ dtProp, dtField:
|
|
|
+ WriteVar(TVarDef(p), d);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ _WriteReplacedItems(c);
|
|
|
+ end;
|
|
|
+
|
|
|
+ procedure WriteReplacedItems;
|
|
|
+ begin
|
|
|
+ _WriteReplacedItems(TClassDef(d));
|
|
|
+ end;
|
|
|
+
|
|
|
+ procedure WriteItems(Regular, Replaced, ReplImpl: boolean);
|
|
|
+ var
|
|
|
+ i: integer;
|
|
|
+ it: TReplDef;
|
|
|
+ begin
|
|
|
+ for i:=0 to d.Count - 1 do begin
|
|
|
+ it:=TReplDef(d[i]);
|
|
|
+ if not (it.DefType in ReplDefs) then
|
|
|
+ continue;
|
|
|
+ if not (it.IsReplImpl or it.IsReplaced) then begin
|
|
|
+ if not Regular then
|
|
|
+ continue;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ if (not Replaced and it.IsReplaced) or (not ReplImpl and it.IsReplImpl) then
|
|
|
+ continue;
|
|
|
+ if it.ReplacedItem <> nil then
|
|
|
+ WrittenItems.Add(it.ReplacedItem);
|
|
|
+ case it.DefType of
|
|
|
+ dtProc:
|
|
|
+ if TProcDef(it).ProcType <> ptConstructor then
|
|
|
+ WriteProc(TProcDef(it));
|
|
|
+ dtProp, dtField:
|
|
|
+ WriteVar(TVarDef(it));
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+var
|
|
|
+ s, ss: string;
|
|
|
+ RegularClass: boolean;
|
|
|
+begin
|
|
|
+ if PreInfo then begin
|
|
|
+ WriteClassInfoVar(d);
|
|
|
+
|
|
|
+ if d.DefType = dtRecord then begin
|
|
|
+ s:=d.Parent.Name + '.' + d.Name;
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn(Format('function _%s_CreateObj(env: PJNIEnv; const r: %s): jobject;', [GetClassPrefix(d), s]));
|
|
|
+ Fps.WriteLn(Format('var pr: ^%s;', [s]));
|
|
|
+ Fps.WriteLn('begin');
|
|
|
+ Fps.IncI;
|
|
|
+ Fps.WriteLn('New(pr); pr^:=r;');
|
|
|
+ Fps.WriteLn(Format('Result:=_CreateJavaObj(env, pr, %s);', [GetTypeInfoVar(d)]));
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+
|
|
|
+ Fps.WriteLn;
|
|
|
+ ss:=Format('_%s_Free', [GetClassPrefix(d)]);
|
|
|
+ Fps.WriteLn(Format('procedure %s(env: PJNIEnv; _self: JObject; r: jlong);', [ss]) + JniCaliing);
|
|
|
+ Fps.WriteLn(Format('var pr: ^%s;', [s]));
|
|
|
+ Fps.WriteLn('begin');
|
|
|
+ Fps.WriteLn('pr:=pointer(ptruint(r));', 1);
|
|
|
+ Fps.WriteLn('Dispose(pr);', 1);
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+
|
|
|
+ AddNativeMethod(d, ss, 'Release', '(J)V');
|
|
|
+ end;
|
|
|
+ exit;
|
|
|
+ end;
|
|
|
+
|
|
|
+ // Java
|
|
|
+ case d.DefType of
|
|
|
+ dtClass:
|
|
|
+ s:='class';
|
|
|
+ dtRecord:
|
|
|
+ s:='record';
|
|
|
+ else
|
|
|
+ s:='';
|
|
|
+ end;
|
|
|
+ WriteComment(d, s);
|
|
|
+ s:='public static class ' + GetJavaClassName(d, nil) + ' extends ';
|
|
|
+ if d.DefType = dtClass then
|
|
|
+ with TClassDef(d) do begin
|
|
|
+ if AncestorClass <> nil then begin
|
|
|
+ ss:=AncestorClass.Name;
|
|
|
+ if ImplementsReplacedItems then
|
|
|
+ ss:='__' + ss;
|
|
|
+ s:=s + ss;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ s:=s + 'PascalObject';
|
|
|
+ end
|
|
|
+ else
|
|
|
+ s:=s + Format('%s.system.Record', [JavaPackage]);
|
|
|
+ Fjs.WriteLn(s + ' {');
|
|
|
+ Fjs.IncI;
|
|
|
+ if d.DefType = dtRecord then begin
|
|
|
+ Fjs.WriteLn('private native void Release(long pasobj);');
|
|
|
+ Fjs.WriteLn(Format('public %s() { }', [d.Name]));
|
|
|
+ Fjs.WriteLn(Format('public void Free() { Release(_pasobj); super.Free(); }', [d.Name]));
|
|
|
+ Fjs.WriteLn(Format('public int Size() { return %d; }', [TRecordDef(d).Size]));
|
|
|
+ end;
|
|
|
+
|
|
|
+ WrittenItems:=TList.Create;
|
|
|
+ try
|
|
|
+ RegularClass:=(d.DefType = dtClass) and not TClassDef(d).HasReplacedItems;
|
|
|
+ if RegularClass then
|
|
|
+ WriteConstructors;
|
|
|
+ // Write regular items
|
|
|
+ WriteItems(True, False, RegularClass);
|
|
|
+ if RegularClass and TClassDef(d).ImplementsReplacedItems then
|
|
|
+ // Write implementation wrappers for replaced mehods
|
|
|
+ WriteReplacedItems;
|
|
|
+
|
|
|
+ Fjs.DecI;
|
|
|
+ Fjs.WriteLn('}');
|
|
|
+ Fjs.WriteLn;
|
|
|
+
|
|
|
+ if (d.DefType = dtClass) and (TClassDef(d).HasReplacedItems) then begin
|
|
|
+ // Write replaced items
|
|
|
+ Fjs.WriteLn(Format('public static class %s extends __%0:s {', [d.AliasName]));
|
|
|
+ Fjs.IncI;
|
|
|
+
|
|
|
+ WriteConstructors;
|
|
|
+ WriteItems(False, True, True);
|
|
|
+
|
|
|
+ if TClassDef(d).ImplementsReplacedItems then
|
|
|
+ // Write implementation wrappers for replaced mehods
|
|
|
+ WriteReplacedItems;
|
|
|
+
|
|
|
+ Fjs.DecI;
|
|
|
+ Fjs.WriteLn('}');
|
|
|
+ Fjs.WriteLn;
|
|
|
+ end;
|
|
|
+ finally
|
|
|
+ WrittenItems.Free;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TWriter.WriteProc(d: TProcDef; Variable: TVarDef; AParent: TDef);
|
|
|
+var
|
|
|
+ i, j, ClassIdx: integer;
|
|
|
+ s, ss: string;
|
|
|
+ err, tf: boolean;
|
|
|
+ pi: TProcInfo;
|
|
|
+ ci: TClassInfo;
|
|
|
+ IsTObject: boolean;
|
|
|
+ tempvars: TStringList;
|
|
|
+ vd: TVarDef;
|
|
|
+ UseTempObjVar: boolean;
|
|
|
+ ItemDef: TDef;
|
|
|
+begin
|
|
|
+ ASSERT(d.DefType = dtProc);
|
|
|
+ if d.IsPrivate or not d.IsUsed then
|
|
|
+ exit;
|
|
|
+ IsTObject:=(d.Parent.DefType = dtClass) and (TClassDef(d.Parent).AncestorClass = nil);
|
|
|
+ if (d.ProcType = ptDestructor) and not IsTObject then
|
|
|
+ exit;
|
|
|
+ if Variable <> nil then
|
|
|
+ ItemDef:=Variable
|
|
|
+ else
|
|
|
+ ItemDef:=d;
|
|
|
+ tempvars:=nil;
|
|
|
+ pi:=TProcInfo.Create;
|
|
|
+ with d do
|
|
|
+ try
|
|
|
+ pi.Name:=Name;
|
|
|
+ s:=GetClassPrefix(d.Parent) + pi.Name;
|
|
|
+ pi.JniName:=s;
|
|
|
+ pi.JniSignature:=GetProcSignature(d);
|
|
|
+ if AParent = nil then begin
|
|
|
+ // Checking duplicate name
|
|
|
+ ClassIdx:=FClasses.IndexOf(GetJavaClassName(d.Parent, ItemDef));
|
|
|
+ if ClassIdx >= 0 then begin
|
|
|
+ ci:=TClassInfo(FClasses.Objects[ClassIdx]);
|
|
|
+ j:=1;
|
|
|
+ repeat
|
|
|
+ err:=False;
|
|
|
+ for i:=0 to ci.Funcs.Count - 1 do
|
|
|
+ with TProcInfo(ci.Funcs[i]) do
|
|
|
+ if CompareText(JniName, pi.JniName) = 0 then begin
|
|
|
+ Inc(j);
|
|
|
+ pi.JniName:=Format('%s_%d', [s, j]);
|
|
|
+ err:=True;
|
|
|
+ break;
|
|
|
+ end;
|
|
|
+ until not err;
|
|
|
+ end;
|
|
|
+
|
|
|
+ err:=False;
|
|
|
+ if ProcType in [ptFunction, ptConstructor] then
|
|
|
+ s:='function'
|
|
|
+ else
|
|
|
+ s:='procedure';
|
|
|
+ s:=s + ' ' + pi.JniName + '(_env: PJNIEnv; _jobj: jobject';
|
|
|
+
|
|
|
+ UseTempObjVar:=(ProcType = ptProcedure) and (Variable <> nil) and (Variable.VarType <> nil) and (Variable.VarType.DefType = dtProcType) and (Variable.Parent.DefType <> dtUnit);
|
|
|
+
|
|
|
+ for j:=0 to Count - 1 do
|
|
|
+ with TVarDef(Items[j]) do begin
|
|
|
+ s:=s + '; ' + Name + ': ';
|
|
|
+ if VarOpt * [voVar, voOut] = [] then
|
|
|
+ s:=s + DefToJniType(VarType, err)
|
|
|
+ else begin
|
|
|
+ s:=s + 'jarray';
|
|
|
+ if tempvars = nil then
|
|
|
+ tempvars:=TStringList.Create;
|
|
|
+ if VarType = nil then
|
|
|
+ err:=True
|
|
|
+ else
|
|
|
+ Tag:=tempvars.AddObject('__tmp_' + Name, d.Items[j]) + 1;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ s:=s + ')';
|
|
|
+
|
|
|
+ if ProcType in [ptFunction, ptConstructor] then
|
|
|
+ s:=s + ': ' + DefToJniType(ReturnType, err);
|
|
|
+ s:=s + '; ' + JniCaliing;
|
|
|
+ if err then begin
|
|
|
+ d.SetNotUsed;
|
|
|
+ s:='// ' + s;
|
|
|
+ end;
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn(s);
|
|
|
+ if err then
|
|
|
+ exit;
|
|
|
+ if (tempvars <> nil) or UseTempObjVar then begin
|
|
|
+ s:='';
|
|
|
+ Fps.WriteLn('var');
|
|
|
+ Fps.IncI;
|
|
|
+ if tempvars <> nil then begin
|
|
|
+ for i:=0 to tempvars.Count - 1 do begin
|
|
|
+ vd:=TVarDef(tempvars.Objects[i]);
|
|
|
+ Fps.WriteLn(Format('%s: %s;', [tempvars[i], vd.VarType.Name]));
|
|
|
+ if IsJavaSimpleType(vd.VarType) then begin
|
|
|
+ Fps.WriteLn(Format('%s_arr: P%s;', [tempvars[i], DefToJniType(vd.VarType, err)]));
|
|
|
+ if s = '' then
|
|
|
+ s:='__iscopy: JBoolean;';
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ if s <> '' then
|
|
|
+ Fps.WriteLn(s);
|
|
|
+ end;
|
|
|
+ if UseTempObjVar then
|
|
|
+ Fps.WriteLn('__objvar: ' + d.Parent.Name + ';');
|
|
|
+ Fps.DecI;
|
|
|
+ end;
|
|
|
+ Fps.WriteLn('begin');
|
|
|
+ Fps.IncI;
|
|
|
+ EHandlerStart;
|
|
|
+
|
|
|
+ tf:=False;
|
|
|
+ // Assign var parameter values to local vars
|
|
|
+ if tempvars <> nil then begin
|
|
|
+ for i:=0 to tempvars.Count - 1 do begin
|
|
|
+ vd:=TVarDef(tempvars.Objects[i]);
|
|
|
+ Fps.WriteLn(Format('if _env^^.GetArrayLength(_env, %s) <> 1 then _RaiseVarParamException(''%s'');', [vd.Name, vd.Name]));
|
|
|
+ if IsJavaSimpleType(vd.VarType) then begin
|
|
|
+ Fps.WriteLn(Format('%s_arr:=_env^^.Get%sArrayElements(_env, %s, __iscopy);', [tempvars[i], GetJniFuncType(vd.VarType), vd.Name]));
|
|
|
+ Fps.WriteLn(Format('if %s_arr = nil then _RaiseVarParamException(''%s'');', [tempvars[i], vd.Name]));
|
|
|
+ s:=tempvars[i] + '_arr^';
|
|
|
+ tf:=True;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ s:=Format('_env^^.GetObjectArrayElement(_env, %s, 0)', [vd.Name]);
|
|
|
+ if voVar in vd.VarOpt then
|
|
|
+ Fps.WriteLn(tempvars[i] + ':=' + JniToPasType(vd.VarType, s, False) + ';');
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ if tf then begin
|
|
|
+ Fps.WriteLn('try');
|
|
|
+ Fps.IncI;
|
|
|
+ end;
|
|
|
+
|
|
|
+ s:='';
|
|
|
+ if Parent.DefType = dtUnit then
|
|
|
+ s:=Parent.Name + '.'
|
|
|
+ else
|
|
|
+ if ProcType = ptConstructor then
|
|
|
+ s:=Parent.Parent.Name + '.' + Parent.Name + '.'
|
|
|
+ else
|
|
|
+ s:=JniToPasType(d.Parent, '_jobj', True) + '.';
|
|
|
+
|
|
|
+ if Variable = nil then begin
|
|
|
+ // Regular proc
|
|
|
+ s:=s + pi.Name;
|
|
|
+ if Count > 0 then begin
|
|
|
+ s:=s + '(';
|
|
|
+ for j:=0 to Count - 1 do begin
|
|
|
+ vd:=TVarDef(Items[j]);
|
|
|
+ if vd.Tag <> 0 then
|
|
|
+ ss:=tempvars[vd.Tag - 1]
|
|
|
+ else begin
|
|
|
+ ss:=Items[j].Name;
|
|
|
+ ss:=JniToPasType(vd.VarType, ss, False);
|
|
|
+ end;
|
|
|
+ if j <> 0 then
|
|
|
+ s:=s + ', ';
|
|
|
+ s:=s + ss;
|
|
|
+ end;
|
|
|
+ s:=s + ')';
|
|
|
+ end;
|
|
|
+ end
|
|
|
+ else begin
|
|
|
+ // Var access
|
|
|
+ if UseTempObjVar then begin
|
|
|
+ System.Delete(s, Length(s), 1);
|
|
|
+ Fps.WriteLn('__objvar:=' + s + ';');
|
|
|
+ s:='__objvar.';
|
|
|
+ end;
|
|
|
+ s:=s + Variable.Name;
|
|
|
+ if Variable.IndexType <> nil then begin
|
|
|
+ ASSERT(Count >= 1);
|
|
|
+ i:=1;
|
|
|
+ s:=Format('%s[%s]', [s, JniToPasType(TVarDef(Items[0]).VarType, Items[0].Name, False)]);
|
|
|
+ end
|
|
|
+ else
|
|
|
+ i:=0;
|
|
|
+ if ProcType = ptProcedure then begin
|
|
|
+ ASSERT(Count = i + 1);
|
|
|
+ if Variable.VarType.DefType = dtProcType then begin
|
|
|
+ Fps.WriteLn(Format('_RefMethodPtr(_env, TMethod(%s), False);', [s]));
|
|
|
+ ss:=Format('_RefMethodPtr(_env, TMethod(%s), True);', [s]);
|
|
|
+ end;
|
|
|
+ s:=s + ':=' + JniToPasType(TVarDef(Items[i]).VarType, Items[i].Name, False);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ if ProcType in [ptFunction, ptConstructor] then
|
|
|
+ s:='Result:=' + PasToJniType(ReturnType, s);
|
|
|
+ s:=s + ';';
|
|
|
+ Fps.WriteLn(s);
|
|
|
+
|
|
|
+ if (Variable <> nil) and UseTempObjVar then
|
|
|
+ Fps.WriteLn(ss);
|
|
|
+
|
|
|
+ // Return var/out parameters
|
|
|
+ if tempvars <> nil then begin
|
|
|
+ for i:=0 to tempvars.Count - 1 do begin
|
|
|
+ vd:=TVarDef(tempvars.Objects[i]);
|
|
|
+ if IsJavaSimpleType(vd.VarType) then
|
|
|
+ Fps.WriteLn(Format('%s_arr^:=%s;', [tempvars[i], PasToJniType(vd.VarType, tempvars[i])]))
|
|
|
+ else
|
|
|
+ Fps.WriteLn(Format('_env^^.SetObjectArrayElement(_env, %s, 0, %s);', [vd.Name, PasToJniType(vd.VarType, tempvars[i])]));
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ if IsTObject and ( (ProcType = ptDestructor) or (CompareText(Name, 'Free') = 0) ) then
|
|
|
+ Fps.WriteLn(Format('_env^^.SetLongField(_env, _jobj, %s.ObjFieldId, 0);', [GetTypeInfoVar(d.Parent)]));
|
|
|
+
|
|
|
+ if tf then begin
|
|
|
+ Fps.WriteLn('finally', -1);
|
|
|
+
|
|
|
+ if tempvars <> nil then begin
|
|
|
+ for i:=0 to tempvars.Count - 1 do begin
|
|
|
+ vd:=TVarDef(tempvars.Objects[i]);
|
|
|
+ if IsJavaSimpleType(vd.VarType) then
|
|
|
+ Fps.WriteLn(Format('_env^^.Release%sArrayElements(_env, %s, %s_arr, 0);', [JavaType[TTypeDef(vd.VarType).BasicType], vd.Name, tempvars[i]]));
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+ end;
|
|
|
+
|
|
|
+ s:='';
|
|
|
+ if ProcType in [ptFunction, ptConstructor] then begin
|
|
|
+ s:='0';
|
|
|
+ if (ReturnType.DefType = dtType) and (TTypeDef(ReturnType).BasicType <= btDouble) then
|
|
|
+ s:='0'
|
|
|
+ else
|
|
|
+ s:=Format('%s(0)', [DefToJniType(ReturnType, err)]);
|
|
|
+ s:='Result:=' + s + ';';
|
|
|
+ end;
|
|
|
+ EHandlerEnd('_env', s);
|
|
|
+
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+ AParent:=d.Parent;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ ClassIdx:=FClasses.IndexOf(GetJavaClassName(AParent, ItemDef));
|
|
|
+
|
|
|
+ if ClassIdx < 0 then begin
|
|
|
+ ci:=TClassInfo.Create;
|
|
|
+ ci.Def:=AParent;
|
|
|
+ s:=GetJavaClassName(AParent, ItemDef);
|
|
|
+ ci.IsCommonClass:=s <> AParent.Name;
|
|
|
+ ClassIdx:=FClasses.AddObject(s, ci);
|
|
|
+ end;
|
|
|
+ TClassInfo(FClasses.Objects[ClassIdx]).Funcs.Add(pi);
|
|
|
+ pi:=nil;
|
|
|
+
|
|
|
+ // Java part
|
|
|
+ s:=GetJavaProcDeclaration(d) + ';';
|
|
|
+ if (Parent.DefType = dtUnit) or (ProcType = ptConstructor) then
|
|
|
+ s:='static ' + s;
|
|
|
+
|
|
|
+ if Variable = nil then
|
|
|
+ Fjs.WriteLn('// ' + GetProcDeclaration(d));
|
|
|
+ if poPrivate in ProcOpt then
|
|
|
+ ss:='private'
|
|
|
+ else
|
|
|
+ if poProtected in ProcOpt then
|
|
|
+ ss:='protected'
|
|
|
+ else
|
|
|
+ ss:='public';
|
|
|
+ Fjs.WriteLn(ss + ' native ' + s);
|
|
|
+ finally
|
|
|
+ pi.Free;
|
|
|
+ tempvars.Free;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TWriter.WriteVar(d: TVarDef; AParent: TDef);
|
|
|
+var
|
|
|
+ pd: TProcDef;
|
|
|
+ t: TTypeDef;
|
|
|
+ s: string;
|
|
|
+begin
|
|
|
+ if not d.IsUsed then
|
|
|
+ exit;
|
|
|
+ if d.VarType <> nil then begin
|
|
|
+ case d.DefType of
|
|
|
+ dtVar:
|
|
|
+ s:='var';
|
|
|
+ dtProp:
|
|
|
+ s:='property';
|
|
|
+ else
|
|
|
+ s:='';
|
|
|
+ end;
|
|
|
+ s:=Trim(s + ' ' + d.Name);
|
|
|
+ if d.IndexType <> nil then
|
|
|
+ s:=s + '[]';
|
|
|
+ Fjs.WriteLn(Format('// %s: %s', [s, d.VarType.Name]));
|
|
|
+ end;
|
|
|
+
|
|
|
+ if voRead in d.VarOpt then begin
|
|
|
+ pd:=TProcDef.Create(nil, dtProc);
|
|
|
+ try
|
|
|
+ pd.IsUsed:=True;
|
|
|
+ pd.Parent:=d.Parent;
|
|
|
+ pd.ProcType:=ptFunction;
|
|
|
+ pd.Name:='get' + d.Name;
|
|
|
+ pd.ReturnType:=d.VarType;
|
|
|
+ if d.IndexType <> nil then
|
|
|
+ with TVarDef.Create(pd, dtParam) do begin
|
|
|
+ Name:='_Index';
|
|
|
+ AliasName:='Index';
|
|
|
+ VarType:=d.IndexType;
|
|
|
+ VarOpt:=[voRead];
|
|
|
+ end;
|
|
|
+ WriteProc(pd, d, AParent);
|
|
|
+ finally
|
|
|
+ pd.Free;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ if voWrite in d.VarOpt then begin
|
|
|
+ pd:=TProcDef.Create(nil, dtProc);
|
|
|
+ try
|
|
|
+ pd.IsUsed:=True;
|
|
|
+ pd.Parent:=d.Parent;
|
|
|
+ pd.ProcType:=ptProcedure;
|
|
|
+ pd.Name:='set' + d.Name;
|
|
|
+ if d.IndexType <> nil then
|
|
|
+ with TVarDef.Create(pd, dtParam) do begin
|
|
|
+ Name:='_Index';
|
|
|
+ AliasName:='Index';
|
|
|
+ VarType:=d.IndexType;
|
|
|
+ VarOpt:=[voRead];
|
|
|
+ end;
|
|
|
+ with TVarDef.Create(pd, dtParam) do begin
|
|
|
+ Name:='_Value';
|
|
|
+ AliasName:='Value';
|
|
|
+ VarType:=d.VarType;
|
|
|
+ VarOpt:=[voRead];
|
|
|
+ end;
|
|
|
+ t:=TTypeDef.Create(nil, dtType);
|
|
|
+ try
|
|
|
+ t.BasicType:=btVoid;
|
|
|
+ pd.ReturnType:=t;
|
|
|
+ WriteProc(pd, d, AParent);
|
|
|
+ finally
|
|
|
+ t.Free;
|
|
|
+ end;
|
|
|
+ finally
|
|
|
+ pd.Free;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TWriter.WriteConst(d: TConstDef);
|
|
|
+var
|
|
|
+ s: string;
|
|
|
+begin
|
|
|
+ if not d.IsUsed then
|
|
|
+ exit;
|
|
|
+ if d.VarType = nil then begin
|
|
|
+ if Copy(d.Value, 1, 1) = '"' then
|
|
|
+ s:='String'
|
|
|
+ else
|
|
|
+ s:='double';
|
|
|
+ end
|
|
|
+ else
|
|
|
+ s:=DefToJavaType(d.VarType);
|
|
|
+ Fjs.WriteLn(Format('public static final %s %s = %s;', [s, d.Name, d.Value]));
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TWriter.WriteEnum(d: TDef);
|
|
|
+var
|
|
|
+ i: integer;
|
|
|
+ s: string;
|
|
|
+begin
|
|
|
+ if not d.IsUsed then
|
|
|
+ exit;
|
|
|
+
|
|
|
+ RegisterPseudoClass(d);
|
|
|
+
|
|
|
+ WriteComment(d, 'enum');
|
|
|
+ Fjs.WriteLn(Format('public enum %s {', [d.Name]));
|
|
|
+ Fjs.IncI;
|
|
|
+ for i:=0 to d.Count - 1 do begin
|
|
|
+ s:=Format('%s (%s)', [d[i].Name, TConstDef(d[i]).Value]);
|
|
|
+ if i <> d.Count - 1 then
|
|
|
+ s:=s + ','
|
|
|
+ else
|
|
|
+ s:=s + ';';
|
|
|
+ Fjs.WriteLn(s);
|
|
|
+ end;
|
|
|
+ Fjs.WriteLn;
|
|
|
+ Fjs.WriteLn('private final int Value;');
|
|
|
+ Fjs.WriteLn(Format('%s(int v) { Value=v; }', [d.Name]));
|
|
|
+ Fjs.WriteLn('public int Ord() { return Value; }');
|
|
|
+ Fjs.DecI;
|
|
|
+ Fjs.WriteLn('}');
|
|
|
+ Fjs.WriteLn;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TWriter.WriteProcType(d: TProcDef; PreInfo: boolean);
|
|
|
+
|
|
|
+ procedure _AccessSimpleArray(vd: TVarDef; VarIndex: integer; DoSet: boolean);
|
|
|
+ begin
|
|
|
+ with vd do begin
|
|
|
+ Fps.WriteLn(Format('_tmp_%s:=_env^^.Get%sArrayElements(_env, _args[%d].L, PJBoolean(nil)^);', [Name, GetJniFuncType(VarType), VarIndex]));
|
|
|
+ Fps.WriteLn(Format('if _tmp_%s <> nil then', [Name]));
|
|
|
+ if DoSet then
|
|
|
+ Fps.WriteLn(Format('_tmp_%s^:=%s;', [Name, PasToJniType(VarType, Name)]), 1)
|
|
|
+ else
|
|
|
+ Fps.WriteLn(Format('%s:=%s;', [Name, JniToPasType(VarType, '_tmp_' + Name + '^', False)]), 1);
|
|
|
+ Fps.WriteLn(Format('_env^^.Release%sArrayElements(_env, _args[%d].L, _tmp_%s, 0);', [GetJniFuncType(VarType), VarIndex, Name]));
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+var
|
|
|
+ vd: TVarDef;
|
|
|
+ i: integer;
|
|
|
+ s, ss: string;
|
|
|
+ err: boolean;
|
|
|
+begin
|
|
|
+ if not d.IsUsed or not (poMethodPtr in d.ProcOpt) then
|
|
|
+ exit;
|
|
|
+
|
|
|
+ if PreInfo then begin
|
|
|
+ WriteClassInfoVar(d);
|
|
|
+
|
|
|
+ // Handler proc
|
|
|
+ Fps.WriteLn;
|
|
|
+ vd:=TVarDef.Create(nil, dtParam);
|
|
|
+ try
|
|
|
+ vd.Name:='_data';
|
|
|
+ vd.VarType:=TTypeDef.Create(nil, dtType);
|
|
|
+ with TTypeDef(vd.VarType) do begin
|
|
|
+ Name:='pointer';
|
|
|
+ BasicType:=btPointer;
|
|
|
+ end;
|
|
|
+ d.Insert(0, vd);
|
|
|
+ Fps.WriteLn(GetProcDeclaration(d, Format('%sHandler', [GetClassPrefix(d)])) + ';');
|
|
|
+ finally
|
|
|
+ vd.VarType.Free;
|
|
|
+ vd.Free;
|
|
|
+ end;
|
|
|
+ Fps.WriteLn('var');
|
|
|
+ Fps.IncI;
|
|
|
+ Fps.WriteLn('_env: PJNIEnv;');
|
|
|
+ Fps.WriteLn('_mpi: _TMethodPtrInfo;');
|
|
|
+ if d.Count > 0 then begin
|
|
|
+ Fps.WriteLn(Format('_args: array[0..%d] of jvalue;', [d.Count - 1]));
|
|
|
+ for i:=0 to d.Count - 1 do
|
|
|
+ with TVarDef(d[i]) do
|
|
|
+ if (VarOpt * [voOut, voVar] <> []) and IsJavaSimpleType(VarType) then
|
|
|
+ Fps.WriteLn(Format('_tmp_%s: P%s;', [Name, DefToJniType(VarType, err)]));
|
|
|
+ end;
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('begin');
|
|
|
+ Fps.IncI;
|
|
|
+ Fps.WriteLn('CurJavaVM^^.GetEnv(CurJavaVM, @_env, JNI_VERSION_1_6);');
|
|
|
+ Fps.WriteLn('_MethodPointersCS.Enter;');
|
|
|
+ Fps.WriteLn('try');
|
|
|
+ Fps.WriteLn('_mpi:=_TMethodPtrInfo(_MethodPointers[-integer(ptruint(_data)) - 1]);', 1);
|
|
|
+ Fps.WriteLn('finally');
|
|
|
+ Fps.WriteLn('_MethodPointersCS.Leave;', 1);
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+
|
|
|
+ for i:=0 to d.Count - 1 do
|
|
|
+ with TVarDef(d[i]) do begin
|
|
|
+ if VarOpt * [voOut, voVar] = [] then begin
|
|
|
+ s:='L';
|
|
|
+ if VarType.DefType = dtType then
|
|
|
+ s:=Copy(JNITypeSig[TTypeDef(VarType).BasicType], 1, 1);
|
|
|
+ ss:=PasToJniType(VarType, Name);
|
|
|
+ end
|
|
|
+ else begin
|
|
|
+ s:='L';
|
|
|
+ if IsJavaSimpleType(VarType) then
|
|
|
+ ss:=Format('_env^^.New%sArray(_env, 1)', [GetJniFuncType(VarType)])
|
|
|
+ else begin
|
|
|
+ if voVar in VarOpt then
|
|
|
+ ss:=PasToJniType(VarType, Name)
|
|
|
+ else
|
|
|
+ ss:='nil';
|
|
|
+ ss:=Format('_env^^.NewObjectArray(_env, 1, %s.ClassRef, %s)', [GetTypeInfoVar(VarType), ss]);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ Fps.WriteLn(Format('_args[%d].%s:=%s;', [i, s, ss]));
|
|
|
+ if (voVar in VarOpt) and IsJavaSimpleType(VarType) then
|
|
|
+ _AccessSimpleArray(TVarDef(d[i]), i, True);
|
|
|
+ end;
|
|
|
+
|
|
|
+ if d.Count > 0 then
|
|
|
+ s:='@_args'
|
|
|
+ else
|
|
|
+ s:='nil';
|
|
|
+ // Calling Java handler
|
|
|
+ s:=Format('_env^^.Call%sMethodA(_env, _mpi.Obj, _mpi.MethodId, %s)', [GetJniFuncType(d.ReturnType), s]);
|
|
|
+ if d.ProcType = ptFunction then
|
|
|
+ s:=Format('Result:=%s', [JniToPasType(d.ReturnType, s, False)]);
|
|
|
+ Fps.WriteLn(s + ';');
|
|
|
+ // Processing var/out parameters
|
|
|
+ for i:=0 to d.Count - 1 do
|
|
|
+ with TVarDef(d[i]) do
|
|
|
+ if VarOpt * [voOut, voVar] <> [] then
|
|
|
+ if IsJavaSimpleType(VarType) then
|
|
|
+ _AccessSimpleArray(TVarDef(d[i]), i, False)
|
|
|
+ else begin
|
|
|
+ s:=Format('_env^^.GetObjectArrayElement(_env, _args[%d].L, 0)', [i]);
|
|
|
+ Fps.WriteLn(Format('%s:=%s;', [Name, JniToPasType(VarType, s, False)]));
|
|
|
+ end;
|
|
|
+
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+
|
|
|
+ // Get handler proc
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn(Format('function %sGetHandler(env: PJNIEnv; jobj: jobject; const ci: _TJavaClassInfo): %s.%s;',
|
|
|
+ [GetClassPrefix(d), d.Parent.Name, d.Name]));
|
|
|
+ Fps.WriteLn('var mpi: _TMethodPtrInfo;');
|
|
|
+ Fps.WriteLn('begin');
|
|
|
+ Fps.IncI;
|
|
|
+ Fps.WriteLn('Result:=nil;');
|
|
|
+ Fps.WriteLn('mpi:=_TMethodPtrInfo(_GetPasObj(env, jobj, ci, False));');
|
|
|
+ Fps.WriteLn('if mpi = nil then exit;');
|
|
|
+ Fps.WriteLn('if mpi.Index = 0 then');
|
|
|
+ Fps.WriteLn('TMethod(Result):=mpi.RealMethod', 1);
|
|
|
+ Fps.WriteLn('else');
|
|
|
+ Fps.WriteLn('with TMethod(Result) do begin', 1);
|
|
|
+ Fps.WriteLn('Data:=pointer(ptruint(-integer(mpi.Index)));', 2);
|
|
|
+ Fps.WriteLn(Format('Code:=@%sHandler;', [GetClassPrefix(d)]), 2);
|
|
|
+ Fps.WriteLn('end;', 1);
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+
|
|
|
+ exit;
|
|
|
+ end;
|
|
|
+
|
|
|
+ err:=False;
|
|
|
+ WriteComment(d, 'procedural type');
|
|
|
+
|
|
|
+ RegisterPseudoClass(d);
|
|
|
+
|
|
|
+ Fjs.WriteLn(Format('/* Pascal prototype: %s */', [GetProcDeclaration(d, 'Execute')]));
|
|
|
+ Fjs.WriteLn(Format('/* Java prototype: %s */', [GetJavaProcDeclaration(d, 'Execute')]));
|
|
|
+
|
|
|
+ Fjs.WriteLn(Format('public static class %s extends %s.system.MethodPtr {', [d.Name, JavaPackage]));
|
|
|
+ Fjs.IncI;
|
|
|
+ Fjs.WriteLn(Format('private String HandlerSig = "%s";', [GetProcSignature(d)]));
|
|
|
+ Fjs.WriteLn(Format('public %s(Object Obj, String MethodName) { Init(Obj, MethodName, HandlerSig); }', [d.Name]));
|
|
|
+ Fjs.WriteLn(Format('public %s() { Init(this, "Execute", HandlerSig); }', [d.Name]));
|
|
|
+ Fjs.WriteLn(Format('protected %s throws NoSuchMethodException { throw new NoSuchMethodException(); }', [GetJavaProcDeclaration(d, 'Execute')]));
|
|
|
+ Fjs.DecI;
|
|
|
+ Fjs.WriteLn('}');
|
|
|
+ Fjs.WriteLn;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TWriter.WriteSet(d: TSetDef);
|
|
|
+begin
|
|
|
+ if not d.IsUsed then
|
|
|
+ exit;
|
|
|
+ if d.ElType = nil then
|
|
|
+ raise Exception.Create('No element type.');
|
|
|
+
|
|
|
+ WriteComment(d, '');
|
|
|
+ Fjs.WriteLn(Format('/* set of %s */', [d.ElType.Name]));
|
|
|
+ if d.Size > 4 then begin
|
|
|
+ Fjs.WriteLn('/* Set size more than 32 bits is not supported */');
|
|
|
+ exit;
|
|
|
+ end;
|
|
|
+
|
|
|
+ RegisterPseudoClass(d);
|
|
|
+
|
|
|
+ Fjs.WriteLn(Format('public static class %s extends %s.system.Set<%s,%s> {', [d.Name, JavaPackage, d.Name, d.ElType.Name]));
|
|
|
+ Fjs.IncI;
|
|
|
+ Fjs.WriteLn(Format('protected byte Size() { return %d; }', [d.Size]));
|
|
|
+ Fjs.WriteLn(Format('protected int Base() { return %d; }', [d.Base]));
|
|
|
+ Fjs.WriteLn(Format('protected int ElMax() { return %d; }', [d.ElMax]));
|
|
|
+ Fjs.WriteLn(Format('protected int Ord(%s Element) { return Element.Ord(); }', [d.ElType.Name]));
|
|
|
+ Fjs.WriteLn(Format('public %s() { }', [d.Name]));
|
|
|
+ Fjs.WriteLn(Format('public %s(%s... Elements) { super(Elements); }', [d.Name, d.ElType.Name]));
|
|
|
+ Fjs.WriteLn(Format('public %0:s(%0:s... Elements) { super(Elements); }', [d.Name]));
|
|
|
+ Fjs.WriteLn(Format('public static %0:s Exclude(%0:s s1, %0:s s2) { %0:s r = new %0:s(s1); r.Exclude(s2); return r; }', [d.Name]));
|
|
|
+ Fjs.WriteLn(Format('public static %0:s Intersect(%0:s s1, %0:s s2) { %0:s r = new %0:s(s1); r.Intersect(s2); return r; }', [d.Name]));
|
|
|
+ Fjs.DecI;
|
|
|
+ Fjs.WriteLn('}');
|
|
|
+ Fjs.WriteLn;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TWriter.WriteUnit(u: TUnitDef);
|
|
|
+var
|
|
|
+ d: TDef;
|
|
|
+ i: integer;
|
|
|
+begin
|
|
|
+ if u.Processed then
|
|
|
+ exit;
|
|
|
+ u.Processed:=True;
|
|
|
+
|
|
|
+ if not u.IsUsed then
|
|
|
+ exit;
|
|
|
+
|
|
|
+ for i:=0 to High(u.UsedUnits) do
|
|
|
+ WriteUnit(u.UsedUnits[i]);
|
|
|
+
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn(Format('{ Unit %s }', [u.Name]));
|
|
|
+
|
|
|
+ u.Name:=LowerCase(u.Name);
|
|
|
+ Fjs:=TTextOutStream.Create(IncludeTrailingPathDelimiter(FPkgDir) + u.Name + '.java', fmCreate);
|
|
|
+ try
|
|
|
+ Fjs.WriteLn(Format('package %s;', [JavaPackage]));
|
|
|
+ if Length(u.UsedUnits) > 0 then begin
|
|
|
+ Fjs.WriteLn;
|
|
|
+ for i:=0 to High(u.UsedUnits) do
|
|
|
+ if u.UsedUnits[i].IsUsed then
|
|
|
+ Fjs.WriteLn(Format('import %s.%s.*;', [JavaPackage, LowerCase(u.UsedUnits[i].Name)]));
|
|
|
+ end;
|
|
|
+ Fjs.WriteLn;
|
|
|
+ Fjs.WriteLn('public class ' + u.Name + ' {');
|
|
|
+ Fjs.IncI;
|
|
|
+ if u.Name = 'system' then begin
|
|
|
+ Fjs.WriteLn('static private boolean _JniLibLoaded = false;');
|
|
|
+ Fjs.WriteLn('public static void InitJni() {');
|
|
|
+ Fjs.WriteLn('if (!_JniLibLoaded) {', 1);
|
|
|
+ Fjs.WriteLn('_JniLibLoaded=true;', 2);
|
|
|
+ Fjs.WriteLn(Format('System.loadLibrary("%s");', [LibName]), 2);
|
|
|
+ Fjs.WriteLn('}', 1);
|
|
|
+ Fjs.WriteLn('}');
|
|
|
+
|
|
|
+ // Support functions
|
|
|
+ Fjs.WriteLn('public native static long AllocMemory(int Size);');
|
|
|
+ AddNativeMethod(u, '_AllocMemory', 'AllocMemory', '(I)J');
|
|
|
+
|
|
|
+ // Base object
|
|
|
+ Fjs.WriteLn;
|
|
|
+ Fjs.WriteLn('public static class PascalObject {');
|
|
|
+ Fjs.IncI;
|
|
|
+ Fjs.WriteLn(Format('static { %s.system.InitJni(); }', [JavaPackage]));
|
|
|
+ Fjs.WriteLn('protected long _pasobj = 0;');
|
|
|
+ Fjs.DecI;
|
|
|
+ Fjs.WriteLn('}');
|
|
|
+ Fjs.WriteLn;
|
|
|
+ Fjs.WriteLn('public static long Pointer(PascalObject obj) { return obj._pasobj; }');
|
|
|
+
|
|
|
+ // Record
|
|
|
+ Fjs.WriteLn;
|
|
|
+ Fjs.WriteLn('public static class Record extends PascalObject {');
|
|
|
+ Fjs.IncI;
|
|
|
+ Fjs.WriteLn('protected void finalize() { Free(); }');
|
|
|
+ Fjs.WriteLn('public Record() { _pasobj = AllocMemory(Size()); }');
|
|
|
+ Fjs.WriteLn('public void Free() { _pasobj = 0; }');
|
|
|
+ Fjs.WriteLn('public int Size() { return 0; }');
|
|
|
+ Fjs.DecI;
|
|
|
+ Fjs.WriteLn('}');
|
|
|
+
|
|
|
+ // Method pointer base class
|
|
|
+ d:=TClassDef.Create(FThisUnit, dtClass);
|
|
|
+ d.Name:='_TMethodPtrInfo';
|
|
|
+ d.AliasName:='MethodPtr';
|
|
|
+ WriteClassInfoVar(d);
|
|
|
+
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('procedure _TMethodPtrInfo_Init(env: PJNIEnv; _self, JavaObj: JObject; AMethodName, AMethodSig: jstring);' + JniCaliing);
|
|
|
+ Fps.WriteLn('var mpi: _TMethodPtrInfo;');
|
|
|
+ Fps.WriteLn('begin');
|
|
|
+ Fps.IncI;
|
|
|
+ EHandlerStart;
|
|
|
+ Fps.WriteLn('mpi:=_TMethodPtrInfo.Create(env, JavaObj, ansistring(_StringFromJString(env, AMethodName)), ansistring(_StringFromJString(env, AMethodSig)));');
|
|
|
+ Fps.WriteLn(Format('env^^.SetLongField(env, _self, %s.ObjFieldId, Int64(ptruint(mpi)));', [GetTypeInfoVar(d)]));
|
|
|
+ EHandlerEnd('env');
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+
|
|
|
+ AddNativeMethod(d, '_TMethodPtrInfo_Init', 'Init', Format('(Ljava/lang/Object;%s%s)V', [JNITypeSig[btString], JNITypeSig[btString]]));
|
|
|
+
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('procedure _TMethodPtrInfo_Release(env: PJNIEnv; _self: JObject);' + JniCaliing);
|
|
|
+ Fps.WriteLn('begin');
|
|
|
+ Fps.IncI;
|
|
|
+ EHandlerStart;
|
|
|
+ Fps.WriteLn(Format('_TMethodPtrInfo(_GetPasObj(env, _self, %s, True)).Release(env);', [GetTypeInfoVar(d)]));
|
|
|
+ EHandlerEnd('env');
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+
|
|
|
+ AddNativeMethod(d, '_TMethodPtrInfo_Release', 'Release', '()V');
|
|
|
+
|
|
|
+ Fjs.WriteLn;
|
|
|
+ Fjs.WriteLn('public static class MethodPtr extends PascalObject {');
|
|
|
+ Fjs.IncI;
|
|
|
+
|
|
|
+ Fjs.WriteLn('private native void Release();');
|
|
|
+ Fjs.WriteLn('protected void finalize() { if (_pasobj != 0) Release(); }');
|
|
|
+ Fjs.WriteLn('protected native void Init(Object Obj, String MethodName, String MethodSignature);');
|
|
|
+ Fjs.DecI;
|
|
|
+ Fjs.WriteLn('}');
|
|
|
+ Fjs.WriteLn;
|
|
|
+
|
|
|
+ // Set base class
|
|
|
+ Fjs.WriteLn('public static class Set<TS extends Set<?,?>,TE> {');
|
|
|
+ Fjs.IncI;
|
|
|
+ Fjs.WriteLn('protected int Value = 0;');
|
|
|
+ Fjs.WriteLn('protected byte Size() { return 0; }');
|
|
|
+ Fjs.WriteLn('protected int Base() { return 0; }');
|
|
|
+ Fjs.WriteLn('protected int ElMax() { return 0; }');
|
|
|
+ Fjs.WriteLn('protected int Ord(TE Element) { return 0; }');
|
|
|
+ Fjs.WriteLn('protected int GetMask(TE Element) {');
|
|
|
+ Fjs.IncI;
|
|
|
+ Fjs.WriteLn('return 1 << (Ord(Element) - Base());');
|
|
|
+ Fjs.DecI;
|
|
|
+ Fjs.WriteLn('}');
|
|
|
+ Fjs.WriteLn('public Set() { }');
|
|
|
+ Fjs.WriteLn('public Set(TE... Elements) { Include(Elements); }');
|
|
|
+ Fjs.WriteLn('public Set(TS... Elements) { for (TS e : Elements) Include(e); }');
|
|
|
+ Fjs.WriteLn('public void Include(TE... Elements) { for (TE e: Elements) Value = Value | GetMask(e); }');
|
|
|
+ Fjs.WriteLn('public void Include(TS s) { Value=Value | s.Value; }');
|
|
|
+ Fjs.WriteLn('public void Exclude(TE... Elements) { for (TE e: Elements) Value = Value & ~GetMask(e); }');
|
|
|
+ Fjs.WriteLn('public void Exclude(TS s) { Value=Value & ~s.Value; }');
|
|
|
+ Fjs.WriteLn('public void Assign(TS s) { Value=s.Value; }');
|
|
|
+ Fjs.WriteLn('public void Intersect(TS s) { Value=Value & s.Value; }');
|
|
|
+ Fjs.WriteLn('public boolean Compare(TS s) { return Value == s.Value; }');
|
|
|
+ Fjs.WriteLn('public boolean Has(TE Element) { return (Value & GetMask(Element)) != 0; }');
|
|
|
+ Fjs.DecI;
|
|
|
+ Fjs.WriteLn('}');
|
|
|
+ Fjs.WriteLn;
|
|
|
+ end;
|
|
|
+ Fjs.WriteLn(Format('static { %s.system.InitJni(); }', [JavaPackage]));
|
|
|
+ Fjs.WriteLn;
|
|
|
+
|
|
|
+ // First pass
|
|
|
+ for i:=0 to u.Count - 1 do begin
|
|
|
+ d:=u[i];
|
|
|
+ if not d.IsUsed then
|
|
|
+ continue;
|
|
|
+ case d.DefType of
|
|
|
+ dtSet, dtEnum:
|
|
|
+ WriteClassInfoVar(d);
|
|
|
+ dtClass, dtRecord:
|
|
|
+ WriteClass(d, True);
|
|
|
+ dtProcType:
|
|
|
+ WriteProcType(TProcDef(d), True);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ // Second pass
|
|
|
+ for i:=0 to u.Count - 1 do begin
|
|
|
+ d:=u[i];
|
|
|
+ if not d.IsUsed then
|
|
|
+ continue;
|
|
|
+ case d.DefType of
|
|
|
+ dtClass, dtRecord:
|
|
|
+ WriteClass(d, False);
|
|
|
+ dtProc:
|
|
|
+ WriteProc(TProcDef(d));
|
|
|
+ dtVar, dtProp:
|
|
|
+ WriteVar(TVarDef(d));
|
|
|
+ dtEnum:
|
|
|
+ WriteEnum(d);
|
|
|
+ dtProcType:
|
|
|
+ WriteProcType(TProcDef(d), False);
|
|
|
+ dtSet:
|
|
|
+ WriteSet(TSetDef(d));
|
|
|
+ dtConst:
|
|
|
+ WriteConst(TConstDef(d));
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ Fjs.DecI;
|
|
|
+ Fjs.WriteLn('}');
|
|
|
+ finally
|
|
|
+ Fjs.Free;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TWriter.WriteOnLoad;
|
|
|
+var
|
|
|
+ i, j: integer;
|
|
|
+ ci: TClassInfo;
|
|
|
+ s, ss, fn: string;
|
|
|
+ d: TTypeDef;
|
|
|
+begin
|
|
|
+ if FClasses.Count = 0 then
|
|
|
+ exit;
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('function JNI_OnLoad(vm: PJavaVM; reserved: pointer): jint;' + JniCaliing);
|
|
|
+
|
|
|
+ Fps.WriteLn('const');
|
|
|
+ for i:=0 to FClasses.Count - 1 do begin
|
|
|
+ ci:=TClassInfo(FClasses.Objects[i]);
|
|
|
+ if ci.Funcs.Count = 0 then
|
|
|
+ continue;
|
|
|
+ Fps.WriteLn(Format(' _%sNativeMethods: array[0..%d] of JNINativeMethod = (', [GetClassPrefix(ci.Def, FClasses[i]), ci.Funcs.Count - 1]));
|
|
|
+ for j:=0 to ci.Funcs.Count - 1 do begin
|
|
|
+ with TProcInfo(ci.Funcs[j]) do
|
|
|
+ Fps.Write(Format(' (name: ''%s''; signature: ''%s''; fnPtr: @%s)', [Name, JniSignature, JniName]));
|
|
|
+ if j < ci.Funcs.Count - 1 then
|
|
|
+ Fps.Write(',');
|
|
|
+ Fps.WriteLn;
|
|
|
+ end;
|
|
|
+ Fps.WriteLn(' );');
|
|
|
+ end;
|
|
|
+
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('var');
|
|
|
+ Fps.IncI;
|
|
|
+ Fps.WriteLn('env: PJNIEnv;');
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('function _Reg(ClassName: PAnsiChar; Methods: PJNINativeMethod; Count: integer; ci: _PJavaClassInfo; const FieldName: ansistring = ''_pasobj''; const FieldSig: ansistring = ''J''): boolean;');
|
|
|
+ Fps.WriteLn('var');
|
|
|
+ Fps.WriteLn('c: jclass;', 1);
|
|
|
+ Fps.WriteLn('begin');
|
|
|
+ Fps.IncI;
|
|
|
+ Fps.WriteLn('Result:=False;');
|
|
|
+ Fps.WriteLn('c:=env^^.FindClass(env, ClassName);');
|
|
|
+ Fps.WriteLn('if c = nil then exit;');
|
|
|
+ Fps.WriteLn('Result:=(Count = 0) or (env^^.RegisterNatives(env, c, Methods, Count) = 0);');
|
|
|
+ Fps.WriteLn('if Result and (ci <> nil) then begin');
|
|
|
+ Fps.IncI;
|
|
|
+ Fps.WriteLn('ci^.ClassRef:=env^^.NewGlobalRef(env, c);');
|
|
|
+ Fps.WriteLn('Result:=ci^.ClassRef <> nil;');
|
|
|
+ Fps.WriteLn('if Result and (FieldName <> '''') then begin');
|
|
|
+ Fps.WriteLn('ci^.ObjFieldId:=env^^.GetFieldID(env, ci^.ClassRef, PAnsiChar(FieldName), PAnsiChar(FieldSig));', 1);
|
|
|
+ Fps.WriteLn('Result:=ci^.ObjFieldId <> nil;', 1);
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('begin', -1);
|
|
|
+ Fps.WriteLn('Result:=JNI_ERR;');
|
|
|
+ Fps.WriteLn('if vm^^.GetEnv(vm, @env, JNI_VERSION_1_6) <> JNI_OK then exit;');
|
|
|
+ Fps.WriteLn('CurJavaVM:=vm;');
|
|
|
+
|
|
|
+ d:=TTypeDef.Create(nil, dtType);
|
|
|
+ try
|
|
|
+ d.BasicType:=btString;
|
|
|
+ s:=JNITypeSig[d.BasicType];
|
|
|
+ s:=Copy(s, 2, Length(s) - 2);
|
|
|
+ Fps.WriteLn(Format('if not _Reg(''%s'', nil, 0, @%s, '''', '''') then exit;',
|
|
|
+ [s, GetTypeInfoVar(d)]));
|
|
|
+ finally
|
|
|
+ d.Free;
|
|
|
+ end;
|
|
|
+
|
|
|
+ for i:=0 to FClasses.Count - 1 do begin
|
|
|
+ ci:=TClassInfo(FClasses.Objects[i]);
|
|
|
+ s:=GetTypeInfoVar(ci.Def);
|
|
|
+ if (s = '') or (ci.IsCommonClass) then
|
|
|
+ s:='nil'
|
|
|
+ else
|
|
|
+ s:='@' + s;
|
|
|
+ if ci.Funcs.Count = 0 then
|
|
|
+ ss:='nil'
|
|
|
+ else
|
|
|
+ ss:=Format('@_%sNativeMethods', [GetClassPrefix(ci.Def, FClasses[i])]);
|
|
|
+ fn:='';
|
|
|
+ if ci.Def <> nil then
|
|
|
+ if ci.Def.DefType in [dtSet, dtEnum] then
|
|
|
+ fn:=', ''Value'', ''I''';
|
|
|
+ Fps.WriteLn(Format('if not _Reg(''%s'', %s, %d, %s%s) then exit;',
|
|
|
+ [GetJavaClassPath(ci.Def, FClasses[i]), ss, ci.Funcs.Count, s, fn]));
|
|
|
+ end;
|
|
|
+
|
|
|
+ Fps.WriteLn('Result:=JNI_VERSION_1_6;');
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('exports JNI_OnLoad;');
|
|
|
+end;
|
|
|
+
|
|
|
+function TWriter.JniToPasType(d: TDef; const v: string; CheckNil: boolean): string;
|
|
|
+var
|
|
|
+ n: string;
|
|
|
+begin
|
|
|
+ Result:=v;
|
|
|
+ if d = nil then
|
|
|
+ exit;
|
|
|
+ case d.DefType of
|
|
|
+ dtType:
|
|
|
+ with TTypeDef(d) do
|
|
|
+ case BasicType of
|
|
|
+ btString, btWideString:
|
|
|
+ begin
|
|
|
+ Result:=Format('_StringFromJString(_env, %s)', [Result]);
|
|
|
+ if BasicType <> btWideString then
|
|
|
+ Result:=Format('%s(%s)', [d.Name, Result]);
|
|
|
+ end;
|
|
|
+ btBoolean:
|
|
|
+ Result:=Format('LongBool(%s)', [Result]);
|
|
|
+ btChar:
|
|
|
+ Result:=Format('char(widechar(%s))', [Result]);
|
|
|
+ btWideChar:
|
|
|
+ Result:=Format('widechar(%s)', [Result]);
|
|
|
+ btEnum:
|
|
|
+ Result:=Format('%s(%s)', [d.Name, Result]);
|
|
|
+ btPointer:
|
|
|
+ Result:=Format('pointer(ptruint(%s))', [Result]);
|
|
|
+ btGuid:
|
|
|
+ Result:=Format('StringToGUID(ansistring(_StringFromJString(_env, %s)))', [Result]);
|
|
|
+ end;
|
|
|
+ dtClass:
|
|
|
+ begin
|
|
|
+ if CheckNil then
|
|
|
+ n:='True'
|
|
|
+ else
|
|
|
+ n:='False';
|
|
|
+ Result:=Format('%s.%s(_GetPasObj(_env, %s, %s, %s))', [d.Parent.Name, d.Name, Result, GetTypeInfoVar(d), n]);
|
|
|
+ end;
|
|
|
+ dtRecord:
|
|
|
+ Result:=Format('%s.%s(_GetPasObj(_env, %s, %s, True)^)', [d.Parent.Name, d.Name, Result, GetTypeInfoVar(d)]);
|
|
|
+ dtProcType:
|
|
|
+ Result:=Format('%sGetHandler(_env, %s, %s)', [GetClassPrefix(d), Result, GetTypeInfoVar(d)]);
|
|
|
+ dtEnum:
|
|
|
+ Result:=Format('%s.%s(_GetIntObjValue(_env, %s, %s))', [d.Parent.Name, d.Name, Result, GetTypeInfoVar(d)]);
|
|
|
+ dtSet:
|
|
|
+ Result:=Format('%s.%s(%s(_GetIntObjValue(_env, %s, %s)))', [d.Parent.Name, d.Name, GetPasIntType(TSetDef(d).Size), Result, GetTypeInfoVar(d)]);
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+function TWriter.PasToJniType(d: TDef; const v: string): string;
|
|
|
+begin
|
|
|
+ Result:=v;
|
|
|
+ if d = nil then
|
|
|
+ exit;
|
|
|
+ case d.DefType of
|
|
|
+ dtType:
|
|
|
+ with TTypeDef(d) do
|
|
|
+ case BasicType of
|
|
|
+ btString, btWideString:
|
|
|
+ Result:=Format('_StringToJString(_env, _JNIString(%s))', [Result]);
|
|
|
+ btBoolean:
|
|
|
+ Result:=Format('jboolean(LongBool(%s))', [Result]);
|
|
|
+ btChar:
|
|
|
+ Result:=Format('jchar(widechar(%s))', [Result]);
|
|
|
+ btWideChar:
|
|
|
+ Result:=Format('jchar(%s)', [Result]);
|
|
|
+ btEnum:
|
|
|
+ Result:=Format('jint(%s)', [Result]);
|
|
|
+ btPointer:
|
|
|
+ Result:=Format('ptruint(pointer(%s))', [Result]);
|
|
|
+ btGuid:
|
|
|
+ Result:=Format('_StringToJString(_env, _JNIString(GUIDToString(%s)))', [Result]);
|
|
|
+ end;
|
|
|
+ dtClass:
|
|
|
+ Result:=Format('_CreateJavaObj(_env, %s, %s)', [Result, GetTypeInfoVar(d)]);
|
|
|
+ dtRecord:
|
|
|
+ Result:=Format('_%s_CreateObj(_env, %s)', [GetClassPrefix(d), Result]);
|
|
|
+ dtProcType:
|
|
|
+ Result:=Format('_CreateMethodPtrObject(_env, TMethod(%s), %s)', [Result, GetTypeInfoVar(d)]);
|
|
|
+ dtEnum:
|
|
|
+ Result:=Format('_CreateIntObj(_env, longint(%s), %s)', [Result, GetTypeInfoVar(d)]);
|
|
|
+ dtSet:
|
|
|
+ Result:=Format('_CreateIntObj(_env, %s(%s), %s)', [GetPasIntType(TSetDef(d).Size), Result, GetTypeInfoVar(d)]);
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+function TWriter.GetTypeInfoVar(ClassDef: TDef): string;
|
|
|
+begin
|
|
|
+ if ClassDef.DefType = dtUnit then
|
|
|
+ Result:=''
|
|
|
+ else
|
|
|
+ if ClassDef.DefType = dtType then
|
|
|
+ Result:='_Java_' + JavaType[TTypeDef(ClassDef).BasicType] + '_Info'
|
|
|
+ else
|
|
|
+ Result:='_JNI_' + ClassDef.Parent.Name + '_' + ClassDef.Name + '_Info';
|
|
|
+end;
|
|
|
+
|
|
|
+function TWriter.GetClassPrefix(ClassDef: TDef; const AClassName: string): string;
|
|
|
+begin
|
|
|
+ if AClassName = '' then
|
|
|
+ Result:=ClassDef.Name
|
|
|
+ else
|
|
|
+ Result:=AClassName;
|
|
|
+ Result:=Result + '_';
|
|
|
+ if ClassDef.DefType <> dtUnit then
|
|
|
+ Result:=ClassDef.Parent.Name + '_' + Result;
|
|
|
+ Result:='JNI_' + Result;
|
|
|
+end;
|
|
|
+
|
|
|
+function TWriter.IsJavaSimpleType(d: TDef): boolean;
|
|
|
+begin
|
|
|
+ Result:=(d <> nil) and (d.DefType = dtType) and (Length(JNITypeSig[TTypeDef(d).BasicType]) = 1);
|
|
|
+end;
|
|
|
+
|
|
|
+function TWriter.GetProcDeclaration(d: TProcDef; const ProcName: string): string;
|
|
|
+var
|
|
|
+ s, ss: string;
|
|
|
+ j: integer;
|
|
|
+begin
|
|
|
+ with d do begin
|
|
|
+ if Count > 0 then
|
|
|
+ s:='('
|
|
|
+ else
|
|
|
+ s:='';
|
|
|
+ for j:=0 to Count - 1 do
|
|
|
+ with TVarDef(Items[j]) do begin
|
|
|
+ if j > 0 then
|
|
|
+ s:=s + '; ';
|
|
|
+ if voVar in VarOpt then
|
|
|
+ s:=s + 'var '
|
|
|
+ else
|
|
|
+ if voOut in VarOpt then
|
|
|
+ s:=s + 'out '
|
|
|
+ else
|
|
|
+ if voConst in VarOpt then
|
|
|
+ s:=s + 'const ';
|
|
|
+ s:=s + Name + ': ' + VarType.Name;
|
|
|
+ end;
|
|
|
+
|
|
|
+ if Count > 0 then
|
|
|
+ s:=s + ')';
|
|
|
+ case ProcType of
|
|
|
+ ptConstructor:
|
|
|
+ ss:='constructor';
|
|
|
+ ptDestructor:
|
|
|
+ ss:='destructor';
|
|
|
+ ptProcedure:
|
|
|
+ ss:='procedure';
|
|
|
+ ptFunction:
|
|
|
+ ss:='function';
|
|
|
+ else
|
|
|
+ ss:='';
|
|
|
+ end;
|
|
|
+ if ProcType in [ptConstructor, ptFunction] then
|
|
|
+ s:=s + ': ' + ReturnType.Name;
|
|
|
+ ss:=ss + ' ';
|
|
|
+ if ProcName <> '' then
|
|
|
+ ss:=ss + ProcName
|
|
|
+ else
|
|
|
+ ss:=ss + Name;
|
|
|
+ Result:=ss + s;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+function TWriter.GetJavaProcDeclaration(d: TProcDef; const ProcName: string): string;
|
|
|
+var
|
|
|
+ s: string;
|
|
|
+ j: integer;
|
|
|
+begin
|
|
|
+ with d do begin
|
|
|
+ if ProcName <> '' then
|
|
|
+ s:=ProcName
|
|
|
+ else
|
|
|
+ s:=AliasName;
|
|
|
+ s:=DefToJavaType(ReturnType) + ' ' + s + '(';
|
|
|
+ for j:=0 to Count - 1 do
|
|
|
+ with TVarDef(Items[j]) do begin
|
|
|
+ if j > 0 then
|
|
|
+ s:=s + ', ';
|
|
|
+ s:=s + DefToJavaType(VarType);
|
|
|
+ if VarOpt * [voVar, voOut] <> [] then
|
|
|
+ s:=s + '[]';
|
|
|
+ s:=s + ' ' + AliasName;
|
|
|
+ end;
|
|
|
+ s:=s + ')';
|
|
|
+ end;
|
|
|
+ Result:=s;
|
|
|
+end;
|
|
|
+
|
|
|
+function TWriter.GetJniFuncType(d: TDef): string;
|
|
|
+begin
|
|
|
+ if IsJavaSimpleType(d) then begin
|
|
|
+ Result:=JavaType[TTypeDef(d).BasicType];
|
|
|
+ Result[1]:=UpCase(Result[1]);
|
|
|
+ end
|
|
|
+ else
|
|
|
+ Result:='Object';
|
|
|
+end;
|
|
|
+
|
|
|
+function TWriter.GetJavaClassName(cls: TDef; it: TDef): string;
|
|
|
+begin
|
|
|
+ Result:=cls.AliasName;
|
|
|
+ if (cls.DefType <> dtClass) or ((it <> nil) and not (it.DefType in ReplDefs)) then
|
|
|
+ exit;
|
|
|
+ with TClassDef(cls) do begin
|
|
|
+ if not (HasReplacedItems or ImplementsReplacedItems) then
|
|
|
+ exit;
|
|
|
+ if ImplementsReplacedItems and not HasReplacedItems then
|
|
|
+ exit;
|
|
|
+ if it <> nil then
|
|
|
+ with TReplDef(it) do begin
|
|
|
+ if (it.DefType = dtProc) and (TProcDef(it).ProcType = ptConstructor) then
|
|
|
+ exit;
|
|
|
+ if IsReplaced or IsReplImpl then
|
|
|
+ exit;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ Result:='__' + Result;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TWriter.RegisterPseudoClass(d: TDef);
|
|
|
+var
|
|
|
+ ci: TClassInfo;
|
|
|
+begin
|
|
|
+ if FClasses.IndexOf(d.Name) < 0 then begin
|
|
|
+ ci:=TClassInfo.Create;
|
|
|
+ ci.Def:=d;
|
|
|
+ FClasses.AddObject(d.Name, ci);
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+function TWriter.GetPasIntType(Size: integer): string;
|
|
|
+begin
|
|
|
+ case Size of
|
|
|
+ 1: Result:='byte';
|
|
|
+ 2: Result:='word';
|
|
|
+ else
|
|
|
+ Result:='cardinal';
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+function TWriter.AddCustomProc(ParentDef: TDef; const JniName, Name: string; RetType: TBasicType; const Params: array of TBasicType): TProcDef;
|
|
|
+var
|
|
|
+ i: integer;
|
|
|
+ vd: TVarDef;
|
|
|
+begin
|
|
|
+ Result:=TProcDef.Create(ParentDef, dtProc);
|
|
|
+ Result.Name:=JniName;
|
|
|
+ Result.AliasName:=Name;
|
|
|
+ if RetType = btVoid then
|
|
|
+ Result.ProcType:=ptProcedure
|
|
|
+ else
|
|
|
+ Result.ProcType:=ptFunction;
|
|
|
+ for i:=0 to High(Params) do begin
|
|
|
+ vd:=TVarDef.Create(Result, dtParam);
|
|
|
+ vd.Name:=Format('p%d', [i + 1]);
|
|
|
+ vd.VarType:=TTypeDef.Create(vd, dtType);
|
|
|
+ TTypeDef(vd.VarType).BasicType:=Params[i];
|
|
|
+ end;
|
|
|
+ Result.ReturnType:=TTypeDef.Create(ParentDef, dtType);
|
|
|
+ TTypeDef(Result.ReturnType).BasicType:=RetType;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TWriter.AddNativeMethod(ParentDef: TDef; const JniName, Name, Signature: string);
|
|
|
+var
|
|
|
+ i: integer;
|
|
|
+ ci: TClassInfo;
|
|
|
+ pi: TProcInfo;
|
|
|
+begin
|
|
|
+ pi:=TProcInfo.Create;
|
|
|
+ pi.Name:=Name;
|
|
|
+ pi.JniName:=JniName;
|
|
|
+ pi.JniSignature:=Signature;
|
|
|
+ i:=FClasses.IndexOf(ParentDef.AliasName);
|
|
|
+ if i < 0 then begin
|
|
|
+ ci:=TClassInfo.Create;
|
|
|
+ ci.Def:=ParentDef;
|
|
|
+ i:=FClasses.AddObject(ParentDef.AliasName, ci);
|
|
|
+ end;
|
|
|
+ TClassInfo(FClasses.Objects[i]).Funcs.Add(pi);
|
|
|
+end;
|
|
|
+
|
|
|
+function TWriter.GetProcSignature(d: TProcDef): string;
|
|
|
+var
|
|
|
+ j: integer;
|
|
|
+begin
|
|
|
+ Result:='(';
|
|
|
+ for j:=0 to d.Count - 1 do
|
|
|
+ with TVarDef(d[j]) do begin
|
|
|
+ if VarOpt * [voVar, voOut] <> [] then
|
|
|
+ Result:=Result + '[';
|
|
|
+ Result:=Result + DefToJniSig(VarType);
|
|
|
+ end;
|
|
|
+ Result:=Result + ')' + DefToJniSig(d.ReturnType);
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TWriter.EHandlerStart;
|
|
|
+begin
|
|
|
+ Fps.WriteLn('try');
|
|
|
+ Fps.IncI;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TWriter.EHandlerEnd(const EnvVarName: string; const ExtraCode: string);
|
|
|
+begin
|
|
|
+ Fps.WriteLn('except', -1);
|
|
|
+ Fps.WriteLn(Format('_HandleJNIException(%s);', [EnvVarName]));
|
|
|
+ if ExtraCode <> '' then
|
|
|
+ Fps.WriteLn(ExtraCode);
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TWriter.WriteClassInfoVar(d: TDef);
|
|
|
+begin
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn(Format('var %s: _TJavaClassInfo;', [GetTypeInfoVar(d)]));
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TWriter.WriteComment(d: TDef; const AType: string);
|
|
|
+begin
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn(Format('{ %s }', [d.Name]));
|
|
|
+
|
|
|
+ Fjs.WriteLn(Format('/* %s %s */', [AType, d.Name]));
|
|
|
+{$ifdef DEBUG}
|
|
|
+ Fjs.WriteLn(Format('/* Ref count: %d */', [d.RefCnt]));
|
|
|
+{$endif}
|
|
|
+end;
|
|
|
+
|
|
|
+{
|
|
|
+procedure TWriter.AddCustomProc(ParentDef: TDef; const JniName, Name: string; RetType: TBasicType; const Params: array of TBasicType);
|
|
|
+var
|
|
|
+ i: integer;
|
|
|
+ ci: TClassInfo;
|
|
|
+ pi: TProcInfo;
|
|
|
+begin
|
|
|
+ pi:=TProcInfo.Create;
|
|
|
+ pi.Name:=Name;
|
|
|
+ pi.JniName:=JniName;
|
|
|
+ pi.JniSignature:='(';
|
|
|
+ for i:=0 to High(Params) do
|
|
|
+ pi.JniSignature:=pi.JniSignature + JNITypeSig[Params[i]];
|
|
|
+ pi.JniSignature:=pi.JniSignature + ')';
|
|
|
+ pi.JniSignature:=pi.JniSignature + JNITypeSig[RetType];
|
|
|
+
|
|
|
+ i:=FClasses.IndexOf(ParentDef.Name);
|
|
|
+ if i < 0 then begin
|
|
|
+ ci:=TClassInfo.Create;
|
|
|
+ ci.Def:=ParentDef;
|
|
|
+ i:=FClasses.AddObject(ParentDef.Name, ci);
|
|
|
+ end;
|
|
|
+ TClassInfo(FClasses.Objects[i]).Funcs.Add(pi);
|
|
|
+end;
|
|
|
+}
|
|
|
+constructor TWriter.Create;
|
|
|
+var
|
|
|
+ i: integer;
|
|
|
+begin
|
|
|
+ Units:=TStringList.Create;
|
|
|
+ FClasses:=TStringList.Create;
|
|
|
+ FClasses.Sorted:=True;
|
|
|
+ JavaPackage:='pas';
|
|
|
+ IncludeList:=TStringList.Create;
|
|
|
+ IncludeList.Duplicates:=dupIgnore;
|
|
|
+ ExcludeList:=TStringList.Create;
|
|
|
+ ExcludeList.Duplicates:=dupIgnore;
|
|
|
+
|
|
|
+ for i:=Low(ExcludeStd) to High(ExcludeStd) do
|
|
|
+ ExcludeList.Add(ExcludeStd[i]);
|
|
|
+ for i:=Low(ExcludeDelphi7) to High(ExcludeDelphi7) do
|
|
|
+ ExcludeList.Add(ExcludeDelphi7[i]);
|
|
|
+
|
|
|
+ FThisUnit:=TUnitDef.Create(nil, dtUnit);
|
|
|
+end;
|
|
|
+
|
|
|
+destructor TWriter.Destroy;
|
|
|
+var
|
|
|
+ i: integer;
|
|
|
+begin
|
|
|
+ for i:=0 to FClasses.Count - 1 do
|
|
|
+ FClasses.Objects[i].Free;
|
|
|
+ FClasses.Free;
|
|
|
+ Units.Free;
|
|
|
+ IncludeList.Free;
|
|
|
+ ExcludeList.Free;
|
|
|
+ FThisUnit.Free;
|
|
|
+ inherited Destroy;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TWriter.ProcessUnits;
|
|
|
+var
|
|
|
+ p: TPPUParser;
|
|
|
+ i: integer;
|
|
|
+ s, ss: string;
|
|
|
+ d: TDef;
|
|
|
+begin
|
|
|
+ if Units.Count = 0 then
|
|
|
+ raise Exception.Create('No unit name specified.');
|
|
|
+ if (OutPath <> '') and not DirectoryExists(OutPath) then
|
|
|
+ raise Exception.CreateFmt('Output path "%s" does not exist.', [OutPath]);
|
|
|
+ if (JavaOutPath <> '') and not DirectoryExists(JavaOutPath) then
|
|
|
+ raise Exception.CreateFmt('Output path "%s" does not exist.', [JavaOutPath]);
|
|
|
+ if LibName = '' then
|
|
|
+ LibName:=AnsiLowerCase(ChangeFileExt(Units[0], '')) + 'jni';
|
|
|
+
|
|
|
+ for i:=0 to IncludeList.Count - 1 do
|
|
|
+ IncludeList[i]:=Trim(IncludeList[i]);
|
|
|
+ IncludeList.Sorted:=True;
|
|
|
+ for i:=0 to ExcludeList.Count - 1 do
|
|
|
+ ExcludeList[i]:=Trim(ExcludeList[i]);
|
|
|
+ ExcludeList.Sorted:=True;
|
|
|
+
|
|
|
+ FThisUnit.Name:=LibName;
|
|
|
+ FThisUnit.AliasName:='system';
|
|
|
+
|
|
|
+ p:=TPPUParser.Create(SearchPath);
|
|
|
+ try
|
|
|
+ p.OnCheckItem:=@DoCheckItem;
|
|
|
+ for i:=0 to Units.Count - 1 do
|
|
|
+ IncludeList.Add(ChangeFileExt(ExtractFileName(Units[i]), ''));
|
|
|
+ for i:=0 to Units.Count - 1 do
|
|
|
+ p.Parse(ChangeFileExt(ExtractFileName(Units[i]), ''));
|
|
|
+
|
|
|
+ if OutPath <> '' then
|
|
|
+ OutPath:=IncludeTrailingPathDelimiter(OutPath);
|
|
|
+ if JavaOutPath <> '' then
|
|
|
+ JavaOutPath:=IncludeTrailingPathDelimiter(JavaOutPath);
|
|
|
+
|
|
|
+ FPkgDir:=JavaOutPath + StringReplace(JavaPackage, '.', DirectorySeparator, [rfReplaceAll]);
|
|
|
+ ForceDirectories(FPkgDir);
|
|
|
+ Fps:=TTextOutStream.Create(OutPath + LibName + '.pas', fmCreate);
|
|
|
+
|
|
|
+ Fps.WriteLn('library '+ LibName + ';');
|
|
|
+ Fps.WriteLn('{$ifdef fpc} {$mode objfpc} {$H+} {$endif}');
|
|
|
+
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('uses');
|
|
|
+ Fps.WriteLn('{$ifndef FPC} Windows, {$endif} {$ifdef unix} cthreads, {$endif} SysUtils, SyncObjs,', 1);
|
|
|
+ s:='';
|
|
|
+ for i:=0 to p.Units.Count - 1 do begin
|
|
|
+ ProcessRules(p.Units[i]);
|
|
|
+ ss:=LowerCase(p.Units[i].Name);
|
|
|
+ if (ss ='system') or (ss = 'objpas') or (ss = 'sysutils') or (ss = 'syncobjs') or (ss = 'jni') then
|
|
|
+ continue;
|
|
|
+ if s <> '' then
|
|
|
+ s:=s + ', ';
|
|
|
+ s:=s + p.Units[i].Name;
|
|
|
+ end;
|
|
|
+ Fps.WriteLn(s + ', jni;', 1);
|
|
|
+
|
|
|
+ // Types
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('type');
|
|
|
+ Fps.IncI;
|
|
|
+ Fps.WriteLn('_JNIString = {$ifdef FPC} unicodestring {$else} widestring {$endif};');
|
|
|
+ Fps.WriteLn('{$ifndef FPC} ptruint = cardinal; {$endif}');
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('_TJavaClassInfo = record');
|
|
|
+ Fps.WriteLn('ClassRef: JClass;', 1);
|
|
|
+ Fps.WriteLn('ObjFieldId: JFieldId;', 1);
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+ Fps.WriteLn('_PJavaClassInfo = ^_TJavaClassInfo;');
|
|
|
+ Fps.DecI;
|
|
|
+
|
|
|
+ Fps.WriteLn;
|
|
|
+ d:=TtypeDef.Create(nil, dtType);
|
|
|
+ TtypeDef(d).BasicType:=btString;
|
|
|
+ Fps.WriteLn(Format('var %s: _TJavaClassInfo;', [GetTypeInfoVar(d)]));
|
|
|
+ d.Free;
|
|
|
+
|
|
|
+ // Support functions
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('function _StringFromJString(env: PJNIEnv; s: jstring): _JNIString;');
|
|
|
+ Fps.WriteLn('var');
|
|
|
+ Fps.WriteLn('p: PJChar;', 1);
|
|
|
+ Fps.WriteLn('c: JBoolean;', 1);
|
|
|
+ Fps.WriteLn('begin');
|
|
|
+ Fps.WriteLn('if s = nil then begin', 1);
|
|
|
+ Fps.WriteLn('Result:='''';', 2);
|
|
|
+ Fps.WriteLn('exit;', 2);
|
|
|
+ Fps.WriteLn('end;', 1);
|
|
|
+ Fps.WriteLn('p:=env^^.GetStringChars(env, s, c);', 1);
|
|
|
+ Fps.WriteLn('SetString(Result, PWideChar(p), env^^.GetStringLength(env, s));', 1);
|
|
|
+ Fps.WriteLn('env^^.ReleaseStringChars(env, s, p);', 1);
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('function _StringToJString(env: PJNIEnv; const s: _JNIString): jstring;');
|
|
|
+ Fps.WriteLn('begin');
|
|
|
+ Fps.WriteLn('Result:=env^^.NewString(env, PJChar(PWideChar(s)), Length(s));', 1);
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('function _CreateJavaObj(env: PJNIEnv; PasObj: pointer; const ci: _TJavaClassInfo): jobject;');
|
|
|
+ Fps.WriteLn('begin');
|
|
|
+ Fps.IncI;
|
|
|
+ Fps.WriteLn('Result:=nil;');
|
|
|
+ Fps.WriteLn('Result:=env^^.AllocObject(env, ci.ClassRef);');
|
|
|
+ Fps.WriteLn('if Result = nil then exit;');
|
|
|
+ Fps.WriteLn('env^^.SetLongField(env, Result, ci.ObjFieldId, Int64(ptruint(PasObj)));');
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('function _GetPasObj(env: PJNIEnv; jobj: jobject; const ci: _TJavaClassInfo; CheckNil: boolean): pointer;');
|
|
|
+ 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 CheckNil and (pasobj = 0) then');
|
|
|
+ Fps.WriteLn('raise Exception.Create(''Attempt to access a released Pascal object.'');', 1);
|
|
|
+ Fps.WriteLn('Result:=pointer(ptruint(pasobj));');
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('procedure _HandleJNIException(env: PJNIEnv);');
|
|
|
+ Fps.WriteLn('begin');
|
|
|
+ Fps.WriteLn('env^^.ThrowNew(env, env^^.FindClass(env, ''java/lang/Exception''), PAnsiChar(Utf8Encode(Exception(ExceptObject).Message)));', 1);
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('procedure _RaiseVarParamException(const VarName: string);');
|
|
|
+ Fps.WriteLn('begin');
|
|
|
+ Fps.WriteLn('raise Exception.CreateFmt(''An array with only single element must be passed as parameter "%s".'', [VarName]);', 1);
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('function _AllocMemory(env: PJNIEnv; jobj: jobject; size: jint): jlong;');
|
|
|
+ Fps.WriteLn('var p: pointer;');
|
|
|
+ Fps.WriteLn('begin');
|
|
|
+ Fps.WriteLn('GetMem(p, size);', 1);
|
|
|
+ Fps.WriteLn('FillChar(p^, size, 0);', 1);
|
|
|
+ Fps.WriteLn('Result:=ptruint(p);', 1);
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+
|
|
|
+ // Method pointer support
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('type');
|
|
|
+ Fps.IncI;
|
|
|
+ Fps.WriteLn('_TMethodPtrInfo = class');
|
|
|
+ Fps.IncI;
|
|
|
+ Fps.WriteLn('Obj: JObject;');
|
|
|
+ Fps.WriteLn('MethodId: JMethodID;');
|
|
|
+ Fps.WriteLn('Index, RefCnt: integer;');
|
|
|
+ Fps.WriteLn('RealMethod: TMethod;');
|
|
|
+ Fps.WriteLn('constructor Create(env: PJNIEnv; JavaObj: JObject; const AMethodName, AMethodSig: ansistring);');
|
|
|
+ Fps.WriteLn('procedure Release(env: PJNIEnv);');
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('var _MethodPointers: array of _TMethodPtrInfo;');
|
|
|
+ Fps.WriteLn('var _MethodPointersCS: TCriticalSection;');
|
|
|
+ Fps.WriteLn;
|
|
|
+
|
|
|
+ Fps.WriteLn('constructor _TMethodPtrInfo.Create(env: PJNIEnv; JavaObj: JObject; const AMethodName, AMethodSig: ansistring);');
|
|
|
+ Fps.WriteLn('var c: JClass;');
|
|
|
+ Fps.WriteLn('begin');
|
|
|
+ Fps.IncI;
|
|
|
+ Fps.WriteLn('RefCnt:=1;');
|
|
|
+ Fps.WriteLn('if (JavaObj = nil) or (AMethodName = '''') then exit;');
|
|
|
+ Fps.WriteLn('c:=env^^.GetObjectClass(env, JavaObj);');
|
|
|
+ Fps.WriteLn('if c = nil then exit;');
|
|
|
+ Fps.WriteLn('MethodId:=env^^.GetMethodID(env, c, PAnsiChar(AMethodName), PAnsiChar(AMethodSig));');
|
|
|
+ Fps.WriteLn('if MethodId = nil then raise Exception.CreateFmt(''Method "%s" does not exist or has wrong parameters.'', [AMethodName]);');
|
|
|
+ Fps.WriteLn('Obj:=env^^.NewGlobalRef(env, JavaObj);');
|
|
|
+ Fps.WriteLn('_MethodPointersCS.Enter;');
|
|
|
+ Fps.WriteLn('try');
|
|
|
+ Fps.IncI;
|
|
|
+ Fps.WriteLn('Index:=Length(_MethodPointers) + 1;');
|
|
|
+ Fps.WriteLn(Format('if Index > %d then raise Exception.Create(''Too many method pointers.'');', [MaxMethodPointers]));
|
|
|
+ Fps.WriteLn('SetLength(_MethodPointers, Index);');
|
|
|
+ Fps.WriteLn('_MethodPointers[Index - 1]:=Self;');
|
|
|
+ Fps.WriteLn('finally', -1);
|
|
|
+ Fps.WriteLn('_MethodPointersCS.Leave;');
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('procedure _TMethodPtrInfo.Release(env: PJNIEnv);');
|
|
|
+ Fps.WriteLn('var i: integer;');
|
|
|
+ Fps.WriteLn('begin');
|
|
|
+ Fps.IncI;
|
|
|
+ Fps.WriteLn('i:=InterlockedDecrement(RefCnt);');
|
|
|
+ Fps.WriteLn('if i <> 0 then exit;');
|
|
|
+ Fps.WriteLn('if Index > 0 then begin');
|
|
|
+ Fps.IncI;
|
|
|
+ Fps.WriteLn('_MethodPointersCS.Enter;');
|
|
|
+ Fps.WriteLn('try');
|
|
|
+ Fps.IncI;
|
|
|
+ Fps.WriteLn('Dec(Index);');
|
|
|
+ Fps.WriteLn('_MethodPointers[Index]:=nil;');
|
|
|
+ Fps.WriteLn('Index:=Length(_MethodPointers);');
|
|
|
+ Fps.WriteLn('while (Index > 0) and (_MethodPointers[Index] = nil) do Dec(Index);');
|
|
|
+ Fps.WriteLn('SetLength(_MethodPointers, Index + 1);');
|
|
|
+ Fps.WriteLn('finally', -1);
|
|
|
+ Fps.WriteLn('_MethodPointersCS.Leave;');
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+ Fps.WriteLn('env^^.DeleteGlobalRef(env, Obj);');
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+ Fps.WriteLn('Self.Destroy;');
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('procedure _RefMethodPtr(env: PJNIEnv; const m: TMethod; AddRef: boolean);');
|
|
|
+ Fps.WriteLn('var i: integer;');
|
|
|
+ Fps.WriteLn('begin');
|
|
|
+ Fps.IncI;
|
|
|
+ Fps.WriteLn('i:=-integer(ptruint(m.Data));');
|
|
|
+ Fps.WriteLn(Format('if (i < 1) or (i > %d) then exit;', [MaxMethodPointers]));
|
|
|
+ Fps.WriteLn('_MethodPointersCS.Enter;');
|
|
|
+ Fps.WriteLn('try');
|
|
|
+ Fps.IncI;
|
|
|
+ Fps.WriteLn('with _MethodPointers[i - 1] do');
|
|
|
+ Fps.WriteLn('if AddRef then InterlockedIncrement(RefCnt) else Release(env);', 1);
|
|
|
+ Fps.WriteLn('finally', -1);
|
|
|
+ Fps.WriteLn('_MethodPointersCS.Leave;');
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('function _CreateMethodPtrObject(env: PJNIEnv; const m: TMethod; const ci: _TJavaClassInfo): jobject;');
|
|
|
+ Fps.WriteLn('var i: integer;');
|
|
|
+ Fps.WriteLn('var mpi: _TMethodPtrInfo;');
|
|
|
+ Fps.WriteLn('begin');
|
|
|
+ Fps.IncI;
|
|
|
+ Fps.WriteLn('_MethodPointersCS.Enter;');
|
|
|
+ Fps.WriteLn('try');
|
|
|
+ Fps.IncI;
|
|
|
+ Fps.WriteLn('i:=-integer(ptruint(m.Data));');
|
|
|
+ Fps.WriteLn(Format('if (i > 0) and (i <= %d) then begin', [MaxMethodPointers]));
|
|
|
+ Fps.WriteLn('mpi:=_MethodPointers[i - 1];', 1);
|
|
|
+ Fps.WriteLn('InterlockedIncrement(mpi.RefCnt);', 1);
|
|
|
+ Fps.WriteLn('end');
|
|
|
+ Fps.WriteLn('else begin');
|
|
|
+ Fps.WriteLn('mpi:=_TMethodPtrInfo.Create(env, nil, '''', '''');', 1);
|
|
|
+ Fps.WriteLn('mpi.RealMethod:=m;', 1);
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+ Fps.WriteLn('finally', -1);
|
|
|
+ Fps.WriteLn('_MethodPointersCS.Leave;');
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+ Fps.WriteLn('Result:=_CreateJavaObj(env, pointer(mpi), ci);');
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+
|
|
|
+ // Set support
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('function _GetIntObjValue(env: PJNIEnv; jobj: jobject; const ci: _TJavaClassInfo): longint;');
|
|
|
+ Fps.WriteLn('begin');
|
|
|
+ Fps.IncI;
|
|
|
+ Fps.WriteLn('if jobj = nil then raise Exception.Create(''Attempt to access a NULL set.'');');
|
|
|
+ Fps.WriteLn('Result:=env^^.GetIntField(env, jobj, ci.ObjFieldId);');
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('function _CreateIntObj(env: PJNIEnv; Value: longint; const ci: _TJavaClassInfo): jobject;');
|
|
|
+ Fps.WriteLn('begin');
|
|
|
+ Fps.IncI;
|
|
|
+ Fps.WriteLn('Result:=nil;');
|
|
|
+ Fps.WriteLn('Result:=env^^.AllocObject(env, ci.ClassRef);');
|
|
|
+ Fps.WriteLn('if Result = nil then exit;');
|
|
|
+ Fps.WriteLn('env^^.SetIntField(env, Result, ci.ObjFieldId, Value);');
|
|
|
+ Fps.DecI;
|
|
|
+ Fps.WriteLn('end;');
|
|
|
+
|
|
|
+ // Write units
|
|
|
+ for i:=0 to p.Units.Count - 1 do
|
|
|
+ with TUnitDef(p.Units[i]) do begin
|
|
|
+ WriteUnit(TUnitDef(p.Units[i]));
|
|
|
+ end;
|
|
|
+
|
|
|
+ WriteOnLoad;
|
|
|
+
|
|
|
+ Fps.WriteLn;
|
|
|
+ Fps.WriteLn('begin');
|
|
|
+ Fps.WriteLn('IsMultiThread:=True;', 1);
|
|
|
+ Fps.WriteLn('_MethodPointersCS:=TCriticalSection.Create;', 1);
|
|
|
+ Fps.WriteLn('end.');
|
|
|
+ finally
|
|
|
+ Fps.Free;
|
|
|
+ p.Free;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+end.
|
|
|
+
|
yury