paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-05-02 03:13:44 +02:00
Code Issues Packages Projects Releases Wiki Activity
446d91eaab
fpc/rtl/java/system.pp
Jonas Maebe 446d91eaab + ansistring support. Items of note: 
o support for ansistring constants. It's done via a detour because the
      JVM only supports UTF-16 string constants (no array of byte or anything
      like that): store every ansicharacter in the lower 8 bits of an
      UTF-16 constant string, and at run time copy the characters to an
      ansistring. The alternative is to generate code that stores every
      character separately to an array.
    o the base ansistring support is implemented in a class called
      AnsistringClass, and an ansistring is simply an instance of this
      class under the hood
    o the compiler currently does generate nil pointers as empty
      ansistrings unlike for unicodestrings, where we always
      explicitly generate an empty string. The reason is that
      unicodestrings are the same as JLString and hence common
      for Java interoperation, while ansistrings are unlikely to
      be used in interaction with external Java code

  * fixed indentation

git-svn-id: branches/jvmbackend@18562 -
2011-08-20 08:10:39 +00:00

502 lines
15 KiB
ObjectPascal
Raw Blame History

{
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-}
{$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;
{ 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;
{$i innr.inc}
{$i jmathh.inc}
{$i jrech.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.
**********************************************************************
}
{$ifndef nounsupported}
{$i astrings.inc}
{$endif}
{$i ustrings.inc}
{$i rtti.inc}
{$i jrec.inc}
{$i jint64.inc}
function min(a,b : longint) : longint;
begin
if a<=b then
min:=a
else
min:=b;
end;
{ 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;
{ 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;
{ 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;
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);
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.
Reference in New Issue View Git Blame Copy Permalink