mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-12-30 00:14:27 +01:00
37aa2d8443
o sets of enums are handled as JUEnumSet instances, others as JUBitSet
derivatives (both smallsets and varsets, to make interoperability with
Java easier)
o special handling of set constants: these have to be constructed at run
time. In case of constants in the code, create an internal constsym to
represent them. These and regular constsyms are then aliased by an
another internal staticvarsym that is used to initialise them in the
unit initialisation code.
o until they are constructed at run time, set constants are encoded as
constant Java strings (with the characters containing the set bits)
o hlcgobj conversion of tcginnode.pass_generate_code() for the genjumps
part (that's the only part of the generic code that's used by the JVM
target)
o as far as explicit typecasting support is concerned, currently the
following ones are supported (both from/to setdefs): ordinal types,
enums, any other set types (whose size is the same on native targets)
o enum setdefs also emit signatures
o overloading routines for different ordinal set types, or for different
enum set types, is not supported on the JVM target
git-svn-id: branches/jvmbackend@18662 -
639 lines
19 KiB
ObjectPascal
639 lines
19 KiB
ObjectPascal
{
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 2006 by Florian Klaempfl
|
|
member of the Free Pascal development team.
|
|
|
|
System unit for embedded systems
|
|
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
|
|
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.
|
|
|
|
**********************************************************************}
|
|
|
|
Unit system;
|
|
|
|
{$namespace org.freepascal.rtl}
|
|
|
|
{*****************************************************************************}
|
|
interface
|
|
{*****************************************************************************}
|
|
|
|
{$define FPC_IS_SYSTEM}
|
|
|
|
{$I-,Q-,H-,R-,V-,P+,T+}
|
|
{$implicitexceptions off}
|
|
{$mode objfpc}
|
|
|
|
{$undef FPC_HAS_FEATURE_ANSISTRINGS}
|
|
{$undef FPC_HAS_FEATURE_TEXTIO}
|
|
{$undef FPC_HAS_FEATURE_VARIANTS}
|
|
{$undef FPC_HAS_FEATURE_CLASSES}
|
|
{$undef FPC_HAS_FEATURE_EXCEPTIONS}
|
|
{$undef FPC_HAS_FEATURE_OBJECTS}
|
|
{$undef FPC_HAS_FEATURE_RTTI}
|
|
{$undef FPC_HAS_FEATURE_FILEIO}
|
|
{$undef FPC_INCLUDE_SOFTWARE_INT64_TO_DOUBLE}
|
|
|
|
Type
|
|
{ The compiler has all integer types defined internally. Here
|
|
we define only aliases }
|
|
DWord = LongWord;
|
|
Cardinal = LongWord;
|
|
Integer = SmallInt;
|
|
UInt64 = QWord;
|
|
SizeInt = Longint;
|
|
SizeUInt = Longint;
|
|
PtrInt = Longint;
|
|
PtrUInt = Longint;
|
|
|
|
ValReal = Double;
|
|
|
|
AnsiChar = Char;
|
|
UnicodeChar = WideChar;
|
|
|
|
{ map comp to int64 }
|
|
Comp = Int64;
|
|
|
|
HResult = type longint;
|
|
|
|
PShortString = ^ShortString;
|
|
|
|
{ Java primitive types }
|
|
jboolean = boolean;
|
|
jbyte = shortint;
|
|
jshort = smallint;
|
|
jint = longint;
|
|
jlong = int64;
|
|
jchar = widechar;
|
|
jfloat = single;
|
|
jdouble = double;
|
|
|
|
Arr1jboolean = array of jboolean;
|
|
Arr1jbyte = array of jbyte;
|
|
Arr1jshort = array of jshort;
|
|
Arr1jint = array of jint;
|
|
Arr1jlong = array of jlong;
|
|
Arr1jchar = array of jchar;
|
|
Arr1jfloat = array of jfloat;
|
|
Arr1jdouble = array of jdouble;
|
|
|
|
Arr2jboolean = array of Arr1jboolean;
|
|
Arr2jbyte = array of Arr1jbyte;
|
|
Arr2jshort = array of Arr1jshort;
|
|
Arr2jint = array of Arr1jint;
|
|
Arr2jlong = array of Arr1jlong;
|
|
Arr2jchar = array of Arr1jchar;
|
|
Arr2jfloat = array of Arr1jfloat;
|
|
Arr2jdouble = array of Arr1jdouble;
|
|
|
|
Arr3jboolean = array of Arr2jboolean;
|
|
Arr3jbyte = array of Arr2jbyte;
|
|
Arr3jshort = array of Arr2jshort;
|
|
Arr3jint = array of Arr2jint;
|
|
Arr3jlong = array of Arr2jlong;
|
|
Arr3jchar = array of Arr2jchar;
|
|
Arr3jfloat = array of Arr2jfloat;
|
|
Arr3jdouble = array of Arr2jdouble;
|
|
|
|
const
|
|
{ max. values for longint and int}
|
|
maxLongint = $7fffffff;
|
|
maxSmallint = 32767;
|
|
|
|
maxint = maxsmallint;
|
|
|
|
|
|
{ Java base class type }
|
|
{$i java_sysh.inc}
|
|
{$i java_sys.inc}
|
|
|
|
type
|
|
TObject = class(JLObject)
|
|
strict private
|
|
DestructorCalled: Boolean;
|
|
public
|
|
procedure Free;
|
|
destructor Destroy; virtual;
|
|
procedure finalize; override;
|
|
end;
|
|
|
|
FpcEnumValueObtainable = interface
|
|
function fpcOrdinal: jint;
|
|
function fpcGenericValueOf(__fpc_int: longint): JLEnum;
|
|
end;
|
|
|
|
{$i innr.inc}
|
|
{$i jmathh.inc}
|
|
{$i jrech.inc}
|
|
{$i jseth.inc}
|
|
{$i sstringh.inc}
|
|
{$i jdynarrh.inc}
|
|
{$i astringh.inc}
|
|
|
|
{$ifndef nounsupported}
|
|
type
|
|
tmethod = record
|
|
code: jlobject;
|
|
end;
|
|
|
|
const
|
|
vtInteger = 0;
|
|
vtBoolean = 1;
|
|
vtChar = 2;
|
|
{$ifndef FPUNONE}
|
|
vtExtended = 3;
|
|
{$endif}
|
|
vtString = 4;
|
|
vtPointer = 5;
|
|
vtPChar = 6;
|
|
vtObject = 7;
|
|
vtClass = 8;
|
|
vtWideChar = 9;
|
|
vtPWideChar = 10;
|
|
vtAnsiString = 11;
|
|
vtCurrency = 12;
|
|
vtVariant = 13;
|
|
vtInterface = 14;
|
|
vtWideString = 15;
|
|
vtInt64 = 16;
|
|
vtQWord = 17;
|
|
vtUnicodeString = 18;
|
|
|
|
type
|
|
TVarRec = record
|
|
case VType : sizeint of
|
|
{$ifdef ENDIAN_BIG}
|
|
vtInteger : ({$IFDEF CPU64}integerdummy1 : Longint;{$ENDIF CPU64}VInteger: Longint);
|
|
vtBoolean : ({$IFDEF CPU64}booldummy : Longint;{$ENDIF CPU64}booldummy1,booldummy2,booldummy3: byte; VBoolean: Boolean);
|
|
vtChar : ({$IFDEF CPU64}chardummy : Longint;{$ENDIF CPU64}chardummy1,chardummy2,chardummy3: byte; VChar: Char);
|
|
vtWideChar : ({$IFDEF CPU64}widechardummy : Longint;{$ENDIF CPU64}wchardummy1,VWideChar: WideChar);
|
|
{$else ENDIAN_BIG}
|
|
vtInteger : (VInteger: Longint);
|
|
vtBoolean : (VBoolean: Boolean);
|
|
vtChar : (VChar: Char);
|
|
vtWideChar : (VWideChar: WideChar);
|
|
{$endif ENDIAN_BIG}
|
|
// vtString : (VString: PShortString);
|
|
// vtPointer : (VPointer: Pointer);
|
|
/// vtPChar : (VPChar: PChar);
|
|
vtObject : (VObject: TObject);
|
|
// vtClass : (VClass: TClass);
|
|
// vtPWideChar : (VPWideChar: PWideChar);
|
|
vtAnsiString : (VAnsiString: JLObject);
|
|
vtCurrency : (VCurrency: Currency);
|
|
// vtVariant : (VVariant: PVariant);
|
|
vtInterface : (VInterface: JLObject);
|
|
vtWideString : (VWideString: JLString);
|
|
vtInt64 : (VInt64: Int64);
|
|
vtUnicodeString : (VUnicodeString: JLString);
|
|
vtQWord : (VQWord: QWord);
|
|
end;
|
|
|
|
{$endif}
|
|
|
|
Function lo(i : Integer) : byte; [INTERNPROC: fpc_in_lo_Word];
|
|
Function lo(w : Word) : byte; [INTERNPROC: fpc_in_lo_Word];
|
|
Function lo(l : Longint) : Word; [INTERNPROC: fpc_in_lo_long];
|
|
Function lo(l : DWord) : Word; [INTERNPROC: fpc_in_lo_long];
|
|
Function lo(i : Int64) : DWord; [INTERNPROC: fpc_in_lo_qword];
|
|
Function lo(q : QWord) : DWord; [INTERNPROC: fpc_in_lo_qword];
|
|
Function hi(i : Integer) : byte; [INTERNPROC: fpc_in_hi_Word];
|
|
Function hi(w : Word) : byte; [INTERNPROC: fpc_in_hi_Word];
|
|
Function hi(l : Longint) : Word; [INTERNPROC: fpc_in_hi_long];
|
|
Function hi(l : DWord) : Word; [INTERNPROC: fpc_in_hi_long];
|
|
Function hi(i : Int64) : DWord; [INTERNPROC: fpc_in_hi_qword];
|
|
Function hi(q : QWord) : DWord; [INTERNPROC: fpc_in_hi_qword];
|
|
|
|
Function chr(b : byte) : AnsiChar; [INTERNPROC: fpc_in_chr_byte];
|
|
|
|
function RorByte(Const AValue : Byte): Byte;[internproc:fpc_in_ror_x];
|
|
function RorByte(Const AValue : Byte;Dist : Byte): Byte;[internproc:fpc_in_ror_x_x];
|
|
|
|
function RolByte(Const AValue : Byte): Byte;[internproc:fpc_in_rol_x];
|
|
function RolByte(Const AValue : Byte;Dist : Byte): Byte;[internproc:fpc_in_rol_x_x];
|
|
|
|
function RorWord(Const AValue : Word): Word;[internproc:fpc_in_ror_x];
|
|
function RorWord(Const AValue : Word;Dist : Byte): Word;[internproc:fpc_in_ror_x_x];
|
|
|
|
function RolWord(Const AValue : Word): Word;[internproc:fpc_in_rol_x];
|
|
function RolWord(Const AValue : Word;Dist : Byte): Word;[internproc:fpc_in_rol_x_x];
|
|
|
|
function RorDWord(Const AValue : DWord): DWord;[internproc:fpc_in_ror_x];
|
|
function RorDWord(Const AValue : DWord;Dist : Byte): DWord;[internproc:fpc_in_ror_x_x];
|
|
|
|
function RolDWord(Const AValue : DWord): DWord;[internproc:fpc_in_rol_x];
|
|
function RolDWord(Const AValue : DWord;Dist : Byte): DWord;[internproc:fpc_in_rol_x_x];
|
|
|
|
function RorQWord(Const AValue : QWord): QWord;[internproc:fpc_in_ror_x];
|
|
function RorQWord(Const AValue : QWord;Dist : Byte): QWord;[internproc:fpc_in_ror_x_x];
|
|
|
|
function RolQWord(Const AValue : QWord): QWord;[internproc:fpc_in_rol_x];
|
|
function RolQWord(Const AValue : QWord;Dist : Byte): QWord;[internproc:fpc_in_rol_x_x];
|
|
|
|
function SarShortint(Const AValue : Shortint): Shortint;[internproc:fpc_in_sar_x];
|
|
function SarShortint(Const AValue : Shortint;Shift : Byte): Shortint;[internproc:fpc_in_sar_x_y];
|
|
|
|
function SarSmallint(Const AValue : Smallint): Smallint;[internproc:fpc_in_sar_x];
|
|
function SarSmallint(Const AValue : Smallint;Shift : Byte): Smallint;[internproc:fpc_in_sar_x_y];
|
|
|
|
function SarLongint(Const AValue : Longint): Longint;[internproc:fpc_in_sar_x];
|
|
function SarLongint(Const AValue : Longint;Shift : Byte): Longint;[internproc:fpc_in_sar_x_y];
|
|
|
|
function SarInt64(Const AValue : Int64): Int64;[internproc:fpc_in_sar_x];
|
|
function SarInt64(Const AValue : Int64;Shift : Byte): Int64;[internproc:fpc_in_sar_x_y];
|
|
|
|
|
|
{$i compproc.inc}
|
|
|
|
{$i ustringh.inc}
|
|
|
|
{*****************************************************************************}
|
|
implementation
|
|
{*****************************************************************************}
|
|
|
|
{i jdynarr.inc}
|
|
{
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 2011 by Jonas Maebe
|
|
member of the Free Pascal development team.
|
|
|
|
This file implements the helper routines for dyn. Arrays in FPC
|
|
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
|
|
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.
|
|
|
|
**********************************************************************
|
|
}
|
|
|
|
|
|
function min(a,b : longint) : longint;
|
|
begin
|
|
if a<=b then
|
|
min:=a
|
|
else
|
|
min:=b;
|
|
end;
|
|
|
|
|
|
{$i sstrings.inc}
|
|
{$i astrings.inc}
|
|
{$i ustrings.inc}
|
|
{$i rtti.inc}
|
|
{$i jrec.inc}
|
|
{$i jset.inc}
|
|
{$i jint64.inc}
|
|
|
|
{ copying helpers }
|
|
|
|
procedure fpc_copy_shallow_array(src, dst: JLObject; srcstart: jint = -1; srccopylen: jint = -1);
|
|
var
|
|
srclen, dstlen: jint;
|
|
begin
|
|
if assigned(src) then
|
|
srclen:=JLRArray.getLength(src)
|
|
else
|
|
srclen:=0;
|
|
if assigned(dst) then
|
|
dstlen:=JLRArray.getLength(dst)
|
|
else
|
|
dstlen:=0;
|
|
if srcstart=-1 then
|
|
srcstart:=0
|
|
else if srcstart>=srclen then
|
|
exit;
|
|
if srccopylen=-1 then
|
|
srccopylen:=srclen
|
|
else if srcstart+srccopylen>srclen then
|
|
srccopylen:=srclen-srcstart;
|
|
{ causes exception in JLSystem.arraycopy }
|
|
if (srccopylen=0) or
|
|
(dstlen=0) then
|
|
exit;
|
|
JLSystem.arraycopy(src,srcstart,dst,0,min(srccopylen,dstlen));
|
|
end;
|
|
|
|
|
|
procedure fpc_copy_jrecord_array(src, dst: TJRecordArray; srcstart: jint = -1; srccopylen: jint = -1);
|
|
var
|
|
i: longint;
|
|
srclen, dstlen: jint;
|
|
begin
|
|
srclen:=length(src);
|
|
dstlen:=length(dst);
|
|
if srcstart=-1 then
|
|
srcstart:=0
|
|
else if srcstart>=srclen then
|
|
exit;
|
|
if srccopylen=-1 then
|
|
srccopylen:=srclen
|
|
else if srcstart+srccopylen>srclen then
|
|
srccopylen:=srclen-srcstart;
|
|
{ no arraycopy, have to clone each element }
|
|
for i:=0 to min(srccopylen,dstlen)-1 do
|
|
dst[i]:=FpcBaseRecordType(src[srcstart+i].clone);
|
|
end;
|
|
|
|
|
|
procedure fpc_copy_jenumset_array(src, dst: TJEnumSetArray; srcstart: jint = -1; srccopylen: jint = -1);
|
|
var
|
|
i: longint;
|
|
srclen, dstlen: jint;
|
|
begin
|
|
srclen:=length(src);
|
|
dstlen:=length(dst);
|
|
if srcstart=-1 then
|
|
srcstart:=0
|
|
else if srcstart>=srclen then
|
|
exit;
|
|
if srccopylen=-1 then
|
|
srccopylen:=srclen
|
|
else if srcstart+srccopylen>srclen then
|
|
srccopylen:=srclen-srcstart;
|
|
{ no arraycopy, have to clone each element }
|
|
for i:=0 to min(srccopylen,dstlen)-1 do
|
|
dst[i]:=JUEnumSet(src[srcstart+i].clone);
|
|
end;
|
|
|
|
|
|
procedure fpc_copy_jbitset_array(src, dst: TJBitSetArray; srcstart: jint = -1; srccopylen: jint = -1);
|
|
var
|
|
i: longint;
|
|
srclen, dstlen: jint;
|
|
begin
|
|
srclen:=length(src);
|
|
dstlen:=length(dst);
|
|
if srcstart=-1 then
|
|
srcstart:=0
|
|
else if srcstart>=srclen then
|
|
exit;
|
|
if srccopylen=-1 then
|
|
srccopylen:=srclen
|
|
else if srcstart+srccopylen>srclen then
|
|
srccopylen:=srclen-srcstart;
|
|
{ no arraycopy, have to clone each element }
|
|
for i:=0 to min(srccopylen,dstlen)-1 do
|
|
dst[i]:=JUBitset(src[srcstart+i].clone);
|
|
end;
|
|
|
|
|
|
procedure fpc_copy_jshortstring_array(src, dst: TShortstringArray; srcstart: jint = -1; srccopylen: jint = -1);
|
|
var
|
|
i: longint;
|
|
srclen, dstlen: jint;
|
|
begin
|
|
srclen:=length(src);
|
|
dstlen:=length(dst);
|
|
if srcstart=-1 then
|
|
srcstart:=0
|
|
else if srcstart>=srclen then
|
|
exit;
|
|
if srccopylen=-1 then
|
|
srccopylen:=srclen
|
|
else if srcstart+srccopylen>srclen then
|
|
srccopylen:=srclen-srcstart;
|
|
{ no arraycopy, have to clone each element }
|
|
for i:=0 to min(srccopylen,dstlen)-1 do
|
|
dst[i]:=ShortstringClass(src[srcstart+i].clone);
|
|
end;
|
|
|
|
|
|
{ 1-dimensional setlength routines }
|
|
|
|
function fpc_setlength_dynarr_generic(aorg, anew: JLObject; deepcopy: boolean; docopy: boolean = true): JLObject;
|
|
var
|
|
orglen, newlen: jint;
|
|
begin
|
|
orglen:=0;
|
|
newlen:=0;
|
|
if not deepcopy then
|
|
begin
|
|
if assigned(aorg) then
|
|
orglen:=JLRArray.getLength(aorg)
|
|
else
|
|
orglen:=0;
|
|
if assigned(anew) then
|
|
newlen:=JLRArray.getLength(anew)
|
|
else
|
|
newlen:=0;
|
|
end;
|
|
if deepcopy or
|
|
(orglen<>newlen) then
|
|
begin
|
|
if docopy then
|
|
fpc_copy_shallow_array(aorg,anew);
|
|
result:=anew
|
|
end
|
|
else
|
|
result:=aorg;
|
|
end;
|
|
|
|
|
|
function fpc_setlength_dynarr_jrecord(aorg, anew: TJRecordArray; deepcopy: boolean): TJRecordArray;
|
|
begin
|
|
if deepcopy or
|
|
(length(aorg)<>length(anew)) then
|
|
begin
|
|
fpc_copy_jrecord_array(aorg,anew);
|
|
result:=anew
|
|
end
|
|
else
|
|
result:=aorg;
|
|
end;
|
|
|
|
|
|
function fpc_setlength_dynarr_jenumset(aorg, anew: TJEnumSetArray; deepcopy: boolean): TJEnumSetArray;
|
|
begin
|
|
if deepcopy or
|
|
(length(aorg)<>length(anew)) then
|
|
begin
|
|
fpc_copy_jenumset_array(aorg,anew);
|
|
result:=anew
|
|
end
|
|
else
|
|
result:=aorg;
|
|
end;
|
|
|
|
|
|
function fpc_setlength_dynarr_jbitset(aorg, anew: TJBitSetArray; deepcopy: boolean): TJBitSetArray;
|
|
begin
|
|
if deepcopy or
|
|
(length(aorg)<>length(anew)) then
|
|
begin
|
|
fpc_copy_jbitset_array(aorg,anew);
|
|
result:=anew
|
|
end
|
|
else
|
|
result:=aorg;
|
|
end;
|
|
|
|
|
|
|
|
function fpc_setlength_dynarr_jshortstring(aorg, anew: TShortstringArray; deepcopy: boolean): TShortstringArray;
|
|
begin
|
|
if deepcopy or
|
|
(length(aorg)<>length(anew)) then
|
|
begin
|
|
fpc_copy_jshortstring_array(aorg,anew);
|
|
result:=anew
|
|
end
|
|
else
|
|
result:=aorg;
|
|
end;
|
|
|
|
|
|
{ multi-dimensional setlength routine }
|
|
function fpc_setlength_dynarr_multidim(aorg, anew: TJObjectArray; deepcopy: boolean; ndim: longint; eletype: jchar): TJObjectArray;
|
|
var
|
|
partdone,
|
|
i: longint;
|
|
|
|
begin
|
|
{ resize the current dimension; no need to copy the subarrays of the old
|
|
array, as the subarrays will be (re-)initialised immediately below }
|
|
{ the srcstart/srccopylen always refers to the first dimension (since copy()
|
|
performs a shallow copy of a dynamic array }
|
|
result:=TJObjectArray(fpc_setlength_dynarr_generic(JLObject(aorg),JLObject(anew),deepcopy,false));
|
|
{ if aorg was empty, there's nothing else to do since result will now
|
|
contain anew, of which all other dimensions are already initialised
|
|
correctly since there are no aorg elements to copy }
|
|
if not assigned(aorg) and
|
|
not deepcopy then
|
|
exit;
|
|
partdone:=min(high(result),high(aorg));
|
|
{ ndim must be >=2 when this routine is called, since it has to return
|
|
an array of java.lang.Object! (arrays are also objects, but primitive
|
|
types are not) }
|
|
if ndim=2 then
|
|
begin
|
|
{ final dimension -> copy the primitive arrays }
|
|
case eletype of
|
|
FPCJDynArrTypeRecord:
|
|
begin
|
|
for i:=low(result) to partdone do
|
|
result[i]:=JLObject(fpc_setlength_dynarr_jrecord(TJRecordArray(aorg[i]),TJRecordArray(anew[i]),deepcopy));
|
|
for i:=succ(partdone) to high(result) do
|
|
result[i]:=JLObject(fpc_setlength_dynarr_jrecord(nil,TJRecordArray(anew[i]),deepcopy));
|
|
end;
|
|
FPCJDynArrTypeEnumSet:
|
|
begin
|
|
for i:=low(result) to partdone do
|
|
result[i]:=JLObject(fpc_setlength_dynarr_jenumset(TJEnumSetArray(aorg[i]),TJEnumSetArray(anew[i]),deepcopy));
|
|
for i:=succ(partdone) to high(result) do
|
|
result[i]:=JLObject(fpc_setlength_dynarr_jenumset(nil,TJEnumSetArray(anew[i]),deepcopy));
|
|
end;
|
|
FPCJDynArrTypeBitSet:
|
|
begin
|
|
for i:=low(result) to partdone do
|
|
result[i]:=JLObject(fpc_setlength_dynarr_jbitset(TJBitSetArray(aorg[i]),TJBitSetArray(anew[i]),deepcopy));
|
|
for i:=succ(partdone) to high(result) do
|
|
result[i]:=JLObject(fpc_setlength_dynarr_jbitset(nil,TJBitSetArray(anew[i]),deepcopy));
|
|
end;
|
|
FPCJDynArrTypeShortstring:
|
|
begin
|
|
for i:=low(result) to partdone do
|
|
result[i]:=JLObject(fpc_setlength_dynarr_jshortstring(TShortstringArray(aorg[i]),TShortstringArray(anew[i]),deepcopy));
|
|
for i:=succ(partdone) to high(result) do
|
|
result[i]:=JLObject(fpc_setlength_dynarr_jshortstring(nil,TShortstringArray(anew[i]),deepcopy));
|
|
end;
|
|
else
|
|
begin
|
|
for i:=low(result) to partdone do
|
|
result[i]:=fpc_setlength_dynarr_generic(aorg[i],anew[i],deepcopy);
|
|
for i:=succ(partdone) to high(result) do
|
|
result[i]:=fpc_setlength_dynarr_generic(nil,anew[i],deepcopy);
|
|
end;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
{ recursively handle the next dimension }
|
|
for i:=low(result) to partdone do
|
|
result[i]:=JLObject(fpc_setlength_dynarr_multidim(TJObjectArray(aorg[i]),TJObjectArray(anew[i]),deepcopy,pred(ndim),eletype));
|
|
for i:=succ(partdone) to high(result) do
|
|
result[i]:=JLObject(fpc_setlength_dynarr_multidim(nil,TJObjectArray(anew[i]),deepcopy,pred(ndim),eletype));
|
|
end;
|
|
end;
|
|
|
|
|
|
function fpc_dynarray_copy(src: JLObject; start, len: longint; ndim: longint; eletype: jchar): JLObject;
|
|
var
|
|
i: longint;
|
|
srclen: longint;
|
|
begin
|
|
if not assigned(src) then
|
|
begin
|
|
result:=nil;
|
|
exit;
|
|
end;
|
|
srclen:=JLRArray.getLength(src);
|
|
if (start=-1) and
|
|
(len=-1) then
|
|
begin
|
|
len:=srclen;
|
|
start:=0;
|
|
end
|
|
else if (start+len>srclen) then
|
|
len:=srclen-start+1;
|
|
result:=JLRArray.newInstance(src.getClass.getComponentType,len);
|
|
if ndim=1 then
|
|
begin
|
|
case eletype of
|
|
FPCJDynArrTypeRecord:
|
|
fpc_copy_jrecord_array(TJRecordArray(src),TJRecordArray(result),start,len);
|
|
FPCJDynArrTypeShortstring:
|
|
fpc_copy_jshortstring_array(TShortstringArray(src),TShortstringArray(result),start,len);
|
|
else
|
|
fpc_copy_shallow_array(src,result,start,len);
|
|
end
|
|
end
|
|
else
|
|
begin
|
|
for i:=0 to len-1 do
|
|
TJObjectArray(result)[i]:=fpc_dynarray_copy(TJObjectArray(src)[start+i],-1,-1,ndim-1,eletype);
|
|
end;
|
|
end;
|
|
|
|
|
|
{i jdynarr.inc end}
|
|
|
|
|
|
|
|
{*****************************************************************************
|
|
Misc. System Dependent Functions
|
|
*****************************************************************************}
|
|
|
|
procedure TObject.Free;
|
|
begin
|
|
if not DestructorCalled then
|
|
begin
|
|
DestructorCalled:=true;
|
|
Destroy;
|
|
end;
|
|
end;
|
|
|
|
|
|
destructor TObject.Destroy;
|
|
begin
|
|
end;
|
|
|
|
|
|
procedure TObject.Finalize;
|
|
begin
|
|
Free;
|
|
end;
|
|
|
|
{*****************************************************************************
|
|
SystemUnit Initialization
|
|
*****************************************************************************}
|
|
|
|
end.
|
|
|